diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,78 @@ ## [Unreleased] +## 0.17.0.0 — 2026-09-17 + +### Breaking Changes + +- `Keiro.Outbox.enqueueProducerEventTx` now takes the source `RecordedEvent` and + a `Word32` emission index instead of a caller-supplied `OutboxId`, and is a pure + `Tx.Transaction ProducerEnqueueOutcome` rather than an `Eff` action producing a + transaction. It derives a deterministic UUIDv8 `OutboxId` and an opaque + `_v1_` message ID from producer source/name and the + source-event coordinates, and returns `ProducerInserted`, + `ProducerDuplicateIdentical`, or `ProducerIdentityConflict` with the differing + field classes (never payload values). Missing `sourceEventId` / + `sourceGlobalPosition` default from the recorded event, and `occurredAt` is + normalized to microseconds. Replays leave retained publication/audit state + untouched. Canonical producer message IDs are no longer TypeIDs; historical + random IDs need a drained checkpoint cutover or an application-owned mapping + before old events are replayed (see ADR-42 and `docs/user/outbox.md`). No schema + migration is required. +- `mkIntegrationProducer` now rejects an empty `messageIdPrefix`. +- `KeiroMetrics` gains an `outboxIdentityConflict` field; code that constructs + the record directly rather than through `newKeiroMetrics` must supply it. + +### New Features + +- Add no-Store delegated inbox single, retry, and sequential batch wrappers for + consumers whose downstream operation owns a durable idempotence receipt. +- Add frozen `delegatedEventId`, safe aggregate-command dispatch, and typed + process-manager result adaptation. Command failures, no-event successes, and + unconfirmed event-ID collisions are never acknowledged as duplicates. +- Add `Keiro.ProcessManager.Reaction`, an additive typed process-manager API + with explicit no-advance and accepted-only follow-ups, atomic saga/timer + mutation, target-keyed dispatch identity, exact accepted-witness recovery, + detailed one-shot results, and strict worker integration. +- Add `Keiro.Timer.cancelTimerTx`, the transaction-level form of guarded timer + cancellation, so callers can compose cancellation with an event append and + other timer mutations. +- Add `Keiro.Outbox.Identity` (`ProducerEventKey`, `ProducerIdentity`, + `ProducerEnqueueOutcome`, `ConflictField`, `deriveIdentity`, + `producerIdentityBytes`, `producerContentDigest`, `differingContentFields`, + `normalizeProducerEvent`), re-exported from `Keiro.Outbox` together with + `deriveProducerIdentity`, `recordProducerEnqueueOutcome`, and + `freshIntegrationEvent`. `Keiro.Outbox.Schema` adds `enqueueProducerOutboxTx`. +- Add the `keiro.outbox.identity.conflict` counter + (`keiroOutboxIdentityConflictName`, `recordOutboxIdentityConflict`), recorded + once after the transaction runner returns. + +### Other Changes + +- Reactions with no schedule or cancel follow-ups skip the empty timer + transaction while preserving dispatch behavior and zero timer effects. +- Read-model compatibility deprecations now name retirement of the frozen + Language 4 generator as their removal boundary instead of an expired version. +- Add matched table/delegated inbox benchmarks for fresh, repeated, duplicate, + chunked, metrics, and long-history receipt-probe workloads. +- Deprecate `mintIntegrationEvent` in favor of `freshIntegrationEvent`, which + names its fresh-envelope behavior explicitly; use `enqueueProducerEventTx` for + replay-safe producer identity. Caller-owned `enqueueOutboxTx` is unchanged. +- The `ProcessManagerAction` documentation now states the real atomicity + boundary: manager-state append and timer writes share one transaction, while + each target command commits in its own. +- Add a producer identity benchmark with retained baseline results. + +- Existing process-manager APIs and positional deterministic identities remain + unchanged. Switching an existing manager name to the reaction runner is an + identity migration: drain source redelivery, partial fan-out, pending timers, + and permitted historical replay first. The reaction family has no automatic + legacy or router identity fallback. +- Outbox reads now preserve non-canonical stored `content_type` text. A retained + row containing, for example, `application/json; charset=utf-8` publishes that + exact `content-type` header instead of normalizing it to `application/json`; + inbox decoding continues to normalize either representation. + ## 0.16.0.0 — 2026-09-07 ### Breaking Changes diff --git a/bench/InboxDelegatedBench.hs b/bench/InboxDelegatedBench.hs new file mode 100644 --- /dev/null +++ b/bench/InboxDelegatedBench.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module InboxDelegatedBench + ( prepareInboxDelegatedBenchmarks, + runInboxDelegatedExplainIfRequested, + ) +where + +import Control.DeepSeq (NFData (..)) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Time (UTCTime (..), secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID qualified as UUID +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error) +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Statement (preparable) +import Hasql.Statement qualified +import Keiro.Command (CommandError (..), CommandResult (..), defaultRunCommandOptions) +import Keiro.Inbox + ( DelegatedOutcome, + InboxDedupePolicy (PreferIntegrationMessageId), + InboxResult (..), + KafkaDeliveryRef (..), + runInboxDelegated, + runInboxDelegatedBatch, + runInboxTransactionBatch, + runInboxTransactionWith, + ) +import Keiro.Inbox.Delegated (delegatedCommand, delegatedEventId) +import Keiro.Inbox.Types (InboxPersistence (PersistFullEnvelope)) +import Keiro.Integration.Event (IntegrationContentType (ApplicationJson), IntegrationEvent (..)) +import Keiro.Prelude +import Keiro.Stream (Stream, stream) +import Keiro.Telemetry (KeiroMetrics) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (PreparedEvent, Store) +import Kiroku.Store.SQL qualified as StoreSQL +import Kiroku.Store.Transaction qualified as StoreTransaction +import Kiroku.Store.Types + ( AppendResult, + EventData (..), + EventId (..), + EventType (..), + ExpectedVersion (NoStream), + StreamName (..), + ) +import System.Directory (createDirectoryIfMissing) +import System.Environment (lookupEnv) +import System.FilePath (takeDirectory) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nfIO) +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude + +deliveryCount :: Int +deliveryCount = 2000 + +payloadSize :: Int +payloadSize = 1024 + +fixedOccurredAt :: UTCTime +fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0) + +data IntakeMode = TableMode | DelegatedMode | DirectDelegatedMode + deriving stock (Eq, Show) + +data Traffic = FreshTraffic | RepeatedTraffic | DuplicateTraffic + deriving stock (Eq, Show) + +data Scenario = Scenario + { name :: !Text, + mode :: !IntakeMode, + chunkSize :: !Int, + traffic :: !Traffic, + metrics :: !(Maybe KeiroMetrics), + runNumber :: !(IORef Int), + duplicateRun :: !(Maybe DownstreamRun) + } + +data DownstreamReceipt + +data DownstreamWork = DownstreamWork + { event :: !IntegrationEvent, + kafka :: !KafkaDeliveryRef, + targetName :: !StreamName, + target :: !(Stream DownstreamReceipt), + marker :: !EventId, + eventData :: !EventData, + prepared :: ![PreparedEvent] + } + +data DownstreamRun = DownstreamRun + { deliveries :: ![(IntegrationEvent, Maybe KafkaDeliveryRef)], + workByMessageId :: !(Map Text DownstreamWork) + } + +instance NFData DownstreamRun where + rnf downstreamRun = + length downstreamRun.deliveries `seq` + Map.size downstreamRun.workByMessageId `seq` + () + +prepareInboxDelegatedBenchmarks :: Store.KirokuStore -> KeiroMetrics -> IO [Benchmark] +prepareInboxDelegatedBenchmarks store metrics = do + runStoreChecked store $ Store.runTransaction (Tx.sql businessTableSql) + scenarios <- concat <$> traverse (prepareScenario store metrics) scenarioInputs + traverse_ (runScenario store) [scenario | scenario <- scenarios, scenario.traffic == FreshTraffic] + pure + ( [ bgroup + (Text.unpack scenario.name) + [ bgroup + (trafficName scenario.traffic) + [bench (metricsName scenario.metrics) (nfIO (runScenario store scenario))] + ] + | scenario <- scenarios + ] + <> [bgroup "delegated-history-duplicate" (historyBenchmark store <$> [10, 1000, 100000])] + ) + +runInboxDelegatedExplainIfRequested :: Store.KirokuStore -> IO () +runInboxDelegatedExplainIfRequested store = + lookupEnv "KEIRO_INBOX_DELEGATED_EXPLAIN" >>= \case + Nothing -> pure () + Just outputPath -> do + downstreamRun <- prepareHistoryRun store 100000 + work <- case Map.elems downstreamRun.workByMessageId of + [] -> fail "explain benchmark run has no work" + item : _ -> pure item + let EventId markerUuid = work.marker + StreamName targetText = work.targetName + sql = + "EXPLAIN (ANALYZE, BUFFERS) SELECT EXISTS (SELECT 1 FROM stream_events se WHERE se.event_id = '" + <> UUID.toText markerUuid + <> "'::uuid AND se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = '" + <> targetText + <> "' AND deleted_at IS NULL))" + statement = + preparable + sql + Encoders.noParams + (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) + planLines <- runStoreChecked store (Store.runTransaction (Tx.statement () statement)) + settings <- + runStoreChecked store $ + Store.runTransaction $ + traverse + ( \settingName -> do + value <- Tx.statement () (settingStatement settingName) + pure (settingName <> " = " <> value) + ) + ["server_version", "fsync", "synchronous_commit", "full_page_writes"] + createDirectoryIfMissing True (takeDirectory outputPath) + Text.IO.writeFile outputPath (Text.unlines (settings <> [""] <> planLines)) + +settingStatement :: Text -> Hasql.Statement.Statement () Text +settingStatement settingName = + preparable + ("SHOW " <> settingName) + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text))) + +scenarioInputs :: [(Text, IntakeMode, Int)] +scenarioInputs = + [ ("table-downstream-single", TableMode, 1), + ("delegated-single", DelegatedMode, 1), + ("delegated-direct-single", DirectDelegatedMode, 1), + ("table-downstream-batch-100", TableMode, 100), + ("delegated-batch-100", DelegatedMode, 100), + ("table-downstream-batch-1000", TableMode, 1000), + ("delegated-batch-1000", DelegatedMode, 1000) + ] + +prepareScenario :: Store.KirokuStore -> KeiroMetrics -> (Text, IntakeMode, Int) -> IO [Scenario] +prepareScenario store metrics (name, mode, chunkSize) = + traverse make [(traffic, mMetrics) | traffic <- [FreshTraffic, RepeatedTraffic, DuplicateTraffic], mMetrics <- [Nothing, Just metrics]] + where + make (traffic, mMetrics) = do + runNumber <- newIORef 0 + duplicateRun <- + case traffic of + DuplicateTraffic -> do + prepared <- prepareDownstreamRun (scenarioPrefix name traffic mMetrics <> "-seed") RepeatedTraffic + seedDuplicateRun store mode prepared + pure (Just prepared) + _ -> pure Nothing + pure Scenario {name, mode, chunkSize, traffic, metrics = mMetrics, runNumber, duplicateRun} + +runScenario :: Store.KirokuStore -> Scenario -> IO () +runScenario store scenario = do + downstreamRun <- case scenario.duplicateRun of + Just prepared -> pure prepared + Nothing -> do + invocation <- atomicModifyIORef' scenario.runNumber (\current -> let next = current + 1 in (next, next)) + prepareDownstreamRun (scenarioPrefix scenario.name scenario.traffic scenario.metrics <> "-" <> Text.pack (show invocation)) scenario.traffic + runStoreChecked store (runDownstream scenario downstreamRun) + +runDownstream :: (IOE :> es, Store :> es) => Scenario -> DownstreamRun -> Eff es () +runDownstream scenario downstreamRun = + case scenario.mode of + TableMode -> + if scenario.chunkSize == 1 + then traverse_ (runTableSingle scenario.metrics downstreamRun.workByMessageId) downstreamRun.deliveries + else traverse_ (runTableBatch scenario.metrics downstreamRun.workByMessageId) (chunksOf scenario.chunkSize downstreamRun.deliveries) + DelegatedMode -> + if scenario.chunkSize == 1 + then traverse_ (runDelegatedSingle scenario.metrics downstreamRun.workByMessageId) downstreamRun.deliveries + else traverse_ (runDelegatedBatch scenario.metrics downstreamRun.workByMessageId) (chunksOf scenario.chunkSize downstreamRun.deliveries) + DirectDelegatedMode -> + traverse_ (runDelegatedDirect downstreamRun.workByMessageId) downstreamRun.deliveries + +runDelegatedDirect :: + (IOE :> es, Store :> es) => + Map Text DownstreamWork -> + (IntegrationEvent, Maybe KafkaDeliveryRef) -> + Eff es () +runDelegatedDirect workById (event, _) = + void (delegatedDownstream (lookupWorkPure workById event)) + +runTableSingle :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Map Text DownstreamWork -> + (IntegrationEvent, Maybe KafkaDeliveryRef) -> + Eff es () +runTableSingle mMetrics workById (event, kafka) = do + work <- lookupWork workById event + outcome <- + runInboxTransactionWith + mMetrics + PersistFullEnvelope + PreferIntegrationMessageId + event + kafka + (\_ -> tableDownstream work) + expectInboxResult outcome + +runTableBatch :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Map Text DownstreamWork -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + Eff es () +runTableBatch mMetrics workById deliveries = do + outcomes <- + runInboxTransactionBatch + mMetrics + 3 + PreferIntegrationMessageId + PersistFullEnvelope + deliveries + (\event -> tableDownstream (lookupWorkPure workById event)) + traverse_ expectInboxResult outcomes + +runDelegatedSingle :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Map Text DownstreamWork -> + (IntegrationEvent, Maybe KafkaDeliveryRef) -> + Eff es () +runDelegatedSingle mMetrics workById (event, kafka) = do + outcome <- + runInboxDelegated + mMetrics + PreferIntegrationMessageId + event + kafka + (\_ delivered -> delegatedDownstream (lookupWorkPure workById delivered)) + expectInboxResult outcome + +runDelegatedBatch :: + (IOE :> es, Store :> es) => + Maybe KeiroMetrics -> + Map Text DownstreamWork -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + Eff es () +runDelegatedBatch mMetrics workById deliveries = do + outcomes <- + runInboxDelegatedBatch + mMetrics + PreferIntegrationMessageId + deliveries + (\_ delivered -> delegatedDownstream (lookupWorkPure workById delivered)) + traverse_ expectInboxResult outcomes + +tableDownstream :: DownstreamWork -> Tx.Transaction Bool +tableDownstream work = do + let EventId markerUuid = work.marker + StreamName targetText = work.targetName + duplicate <- Tx.statement (targetText, markerUuid) StoreSQL.eventExistsInStreamStmt + if duplicate + then pure False + else do + StoreTransaction.appendToStreamTx work.targetName NoStream work.prepared fixedOccurredAt >>= \case + Left _ -> Tx.condemn >> pure False + Right _ -> Tx.sql businessEffectSql >> pure True + +delegatedDownstream :: + (IOE :> es, Store :> es) => + DownstreamWork -> + Eff es (DelegatedOutcome (CommandResult DownstreamReceipt)) +delegatedDownstream work = do + outcome <- + delegatedCommand + defaultRunCommandOptions + work.targetName + work.marker + (\_ -> first StoreFailed <$> appendDownstream work) + case outcome of + Left err -> liftIO (fail ("unexpected delegated benchmark command result: " <> show err)) + Right result -> pure result + +appendDownstream :: + (IOE :> es, Store :> es) => + DownstreamWork -> + Eff es (Either Store.StoreError (CommandResult DownstreamReceipt)) +appendDownstream work = + StoreTransaction.runTransactionAppending work.targetName NoStream [work.eventData] $ \appendResult -> do + Tx.sql businessEffectSql + pure (commandResult work.target appendResult) + +commandResult :: Stream DownstreamReceipt -> AppendResult -> CommandResult DownstreamReceipt +commandResult target appendResult = + CommandResult + { target, + streamVersion = appendResult.streamVersion, + globalPosition = Just appendResult.globalPosition, + eventsAppended = 1 + } + +expectInboxResult :: (IOE :> es) => Either err (InboxResult a) -> Eff es () +expectInboxResult = \case + Right (InboxProcessed _) -> pure () + Right InboxDuplicate -> pure () + Right _ -> liftIO (fail "unexpected inbox benchmark classification") + Left _ -> liftIO (fail "unexpected inbox benchmark policy failure") + +lookupWork :: (IOE :> es) => Map Text DownstreamWork -> IntegrationEvent -> Eff es DownstreamWork +lookupWork workById event = + case Map.lookup event.messageId workById of + Just work -> pure work + Nothing -> liftIO (fail ("missing downstream benchmark work for " <> Text.unpack event.messageId)) + +lookupWorkPure :: Map Text DownstreamWork -> IntegrationEvent -> DownstreamWork +lookupWorkPure workById event = + case Map.lookup event.messageId workById of + Just work -> work + Nothing -> error ("missing downstream benchmark work for " <> Text.unpack event.messageId) + +prepareDownstreamRun :: Text -> Traffic -> IO DownstreamRun +prepareDownstreamRun prefix traffic = do + uniqueWorks <- traverse (prepareWork prefix) uniqueIndexes + let selected = case (traffic, uniqueWorks) of + (FreshTraffic, _) -> uniqueWorks + (RepeatedTraffic, work : _) -> Prelude.replicate deliveryCount work + (DuplicateTraffic, work : _) -> Prelude.replicate deliveryCount work + _ -> error "prepareDownstreamRun: traffic generated no work" + deliveries = [(work.event, Just work.kafka) | work <- selected] + workByMessageId = Map.fromList [(work.event.messageId, work) | work <- uniqueWorks] + pure DownstreamRun {deliveries, workByMessageId} + where + uniqueIndexes = case traffic of + FreshTraffic -> [1 .. deliveryCount] + RepeatedTraffic -> [1] + DuplicateTraffic -> [1] + +prepareWork :: Text -> Int -> IO DownstreamWork +prepareWork prefix item = do + let suffix = prefix <> "-" <> Text.pack (show item) + messageId = "bench-delegated-" <> suffix + event = integrationEvent messageId + kafka = KafkaDeliveryRef "bench.inbox.delegated.v1" 0 (fromIntegral item) + targetName = StreamName ("benchInbox-" <> suffix) + target = stream ("benchInbox-" <> suffix) + marker = delegatedEventId "keiro-bench" event.source messageId targetName "apply" + eventData = receiptEvent marker + prepared <- StoreTransaction.prepareEventsIO [eventData] + pure DownstreamWork {event, kafka, targetName, target, marker, eventData, prepared} + +seedDuplicateRun :: Store.KirokuStore -> IntakeMode -> DownstreamRun -> IO () +seedDuplicateRun store mode downstreamRun = + runStoreChecked store do + case downstreamRun.deliveries of + [] -> liftIO (fail "duplicate benchmark run has no delivery") + delivery : _ -> + case mode of + TableMode -> runTableSingle Nothing downstreamRun.workByMessageId delivery + DelegatedMode -> runDelegatedSingle Nothing downstreamRun.workByMessageId delivery + DirectDelegatedMode -> runDelegatedDirect downstreamRun.workByMessageId delivery + +historyBenchmark :: Store.KirokuStore -> Int -> Benchmark +historyBenchmark store historySize = + env (prepareHistoryRun store historySize) $ \downstreamRun -> + bench ("events-" <> show historySize) $ + nfIO $ + runStoreChecked store $ + traverse_ (runDelegatedSingle Nothing downstreamRun.workByMessageId) downstreamRun.deliveries + +prepareHistoryRun :: Store.KirokuStore -> Int -> IO DownstreamRun +prepareHistoryRun store historySize = do + downstreamRun <- prepareDownstreamRun ("history-" <> Text.pack (show historySize)) DuplicateTraffic + seedDuplicateRun store DelegatedMode downstreamRun + case Map.elems downstreamRun.workByMessageId of + [] -> fail "history benchmark run has no work" + work : _ -> + runStoreChecked store $ + traverse_ + (\chunk -> void (Store.appendToStream work.targetName Store.AnyVersion chunk)) + (chunksOf 1000 (Prelude.replicate (max 0 (historySize - 1)) historyEvent)) + pure downstreamRun + +historyEvent :: EventData +historyEvent = + EventData + { eventId = Nothing, + eventType = EventType "BenchHistoricalEvent", + payload = Aeson.toJSON (0 :: Int), + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + +integrationEvent :: Text -> IntegrationEvent +integrationEvent messageId = + IntegrationEvent + { messageId, + source = "bench.inbox.delegated", + destination = "bench.inbox.delegated.v1", + key = Just messageId, + eventType = "BenchDelegatedIntake", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = Nothing, + sourceEventId = Nothing, + sourceGlobalPosition = Nothing, + payloadBytes = ByteString.replicate payloadSize 65, + occurredAt = fixedOccurredAt, + causationId = Nothing, + correlationId = Nothing, + traceContext = Nothing, + attributes = Nothing + } + +receiptEvent :: EventId -> EventData +receiptEvent marker = + EventData + { eventId = Just marker, + eventType = EventType "BenchDelegatedApplied", + payload = Aeson.toJSON ("applied" :: Text), + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } + +scenarioPrefix :: Text -> Traffic -> Maybe KeiroMetrics -> Text +scenarioPrefix name traffic mMetrics = + Text.intercalate "-" [name, Text.pack (trafficName traffic), Text.pack (metricsName mMetrics)] + +trafficName :: Traffic -> String +trafficName = \case + FreshTraffic -> "fresh" + RepeatedTraffic -> "repeated-key" + DuplicateTraffic -> "all-duplicate" + +metricsName :: Maybe KeiroMetrics -> String +metricsName = maybe "metrics-off" (const "metrics-on") + +chunksOf :: Int -> [a] -> [[a]] +chunksOf n xs + | n <= 0 = error "chunksOf: non-positive chunk size" + | otherwise = + case splitAt n xs of + ([], _) -> [] + (chunk, rest) -> chunk : chunksOf n rest + +businessTableSql :: ByteString.ByteString +businessTableSql = + "CREATE TABLE IF NOT EXISTS keiro.keiro_inbox_delegated_bench_effect (singleton bool PRIMARY KEY DEFAULT true, applied bigint NOT NULL DEFAULT 0); INSERT INTO keiro.keiro_inbox_delegated_bench_effect (singleton, applied) VALUES (true, 0) ON CONFLICT (singleton) DO NOTHING" + +businessEffectSql :: ByteString.ByteString +businessEffectSql = + "UPDATE keiro.keiro_inbox_delegated_bench_effect SET applied = applied + 1 WHERE singleton = true" + +runStoreChecked :: Store.KirokuStore -> Eff '[Store, Error Store.StoreError, IOE] a -> IO a +runStoreChecked store action = do + result <- Store.runStoreIO store action + case result of + Left err -> fail (show err) + Right value -> pure value diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -17,6 +17,7 @@ import Data.UUID qualified as UUID import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error) +import InboxDelegatedBench (prepareInboxDelegatedBenchmarks, runInboxDelegatedExplainIfRequested) import Keiki.Core ( Edge (..), HsPred, @@ -92,6 +93,7 @@ import OpenTelemetry.MeterProvider (createMeterProvider, defaultSdkMeterProviderOptions) import OpenTelemetry.Metric.Core (getMeter) import OpenTelemetry.Resource (emptyMaterializedResources) +import ProducerIdentityBench (producerIdentityBenchmarks) import ReadModelBench ( readModelBenchmarks, runReadModelExplainEvidenceIfRequested, @@ -158,10 +160,12 @@ readModelFixture <- setupReadModelBench readModelStore readModelRunner runReadModelExplainEvidenceIfRequested readModelFixture runReadModelLatencyEvidenceIfRequested readModelFixture - defaultMain (benchmarks store runner metrics rebuildRunCounter <> readModelBenchmarks readModelFixture) + delegatedInboxBenchmarks <- prepareInboxDelegatedBenchmarks store metrics + runInboxDelegatedExplainIfRequested store + defaultMain (benchmarks store runner metrics rebuildRunCounter delegatedInboxBenchmarks <> readModelBenchmarks readModelFixture <> producerIdentityBenchmarks store rebuildRunCounter) -benchmarks :: Store.KirokuStore -> StoreRunner -> Telemetry.KeiroMetrics -> IORef Int -> [Benchmark] -benchmarks store runner metrics rebuildRunCounter = +benchmarks :: Store.KirokuStore -> StoreRunner -> Telemetry.KeiroMetrics -> IORef Int -> [Benchmark] -> [Benchmark] +benchmarks store runner metrics rebuildRunCounter delegatedInboxBenchmarks = [ bgroup "outbox" [ scenarioBench store hotKey, @@ -173,7 +177,8 @@ [ inboxScenarioBench store (singleFull metrics), inboxScenarioBench store singleNoMetrics, inboxScenarioBench store batch100, - inboxScenarioBench store singleSlim + inboxScenarioBench store singleSlim, + bgroup "downstream" delegatedInboxBenchmarks ], bgroup "command" diff --git a/bench/ProducerIdentityBench.hs b/bench/ProducerIdentityBench.hs new file mode 100644 --- /dev/null +++ b/bench/ProducerIdentityBench.hs @@ -0,0 +1,115 @@ +-- | Compare the pre-plan-164 fresh-ID path with deterministic producer writes. +module ProducerIdentityBench (producerIdentityBenchmarks) where + +import Control.Monad (forM, forM_) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.IORef (IORef, atomicModifyIORef') +import Data.Time (UTCTime (..), secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID qualified as UUID +import Keiro.Integration.Event +import Keiro.Outbox +import Keiro.Prelude +import Kiroku.Store qualified as Store +import Kiroku.Store.Types (EventId (..), EventType (..), GlobalPosition (..), RecordedEvent (..), StreamId (..), StreamVersion (..)) +import Test.Tasty.Bench (Benchmark, bcompareWithin, bench, bgroup, nf, nfIO) +import "hasql-transaction" Hasql.Transaction qualified as Tx + +producerIdentityBenchmarks :: Store.KirokuStore -> IORef Int -> [Benchmark] +producerIdentityBenchmarks store sequenceRef = + [ bgroup + "producer-identity" + [ bench "derive-v1" $ nf identityText (ProducerEventKey (EventId (UUID.fromWords 0 0 0 1)) 0), + bench "legacy-fresh-1000" $ nfIO (run True False False), + bcompareWithin 0 1.10 "$0 == \"All.producer-identity.legacy-fresh-1000\"" $ bench "deterministic-fresh-1000" $ nfIO (run True True False), + bench "deterministic-fresh-and-replay-1000" $ nfIO (run True True True), + bench "legacy-single-tx-per-event-1000" $ nfIO (run False False False), + bcompareWithin 0 1.10 "$0 == \"All.producer-identity.legacy-single-tx-per-event-1000\"" $ bench "deterministic-single-tx-per-event-1000" $ nfIO (run False True False) + ] + ] + where + run batch deterministic replay = do + generation <- atomicModifyIORef' sequenceRef (\n -> (n + 1, n + 1)) + result <- Store.runStoreIO store $ do + Store.runTransaction (Tx.sql "TRUNCATE keiro.keiro_outbox") + let recorded = [sourceEvent generation i | i <- [1 .. 1000]] + if deterministic + then do + let actions = fmap (\event -> enqueueProducerEventTx producer event 0 draft) recorded + if batch + then do + first <- Store.runTransaction (sequence actions) + unless (all isInserted first) (error "producer benchmark failed to insert") + else forM_ actions $ \action -> do + outcome <- Store.runTransaction action + unless (isInserted outcome) (error "producer benchmark failed to insert") + when replay $ do + second <- Store.runTransaction (sequence actions) + unless (all isDuplicate second) (error "producer benchmark failed to replay") + else do + -- Match the old helper's preparation boundary: bulk preparation + -- for bulk SQL, and preparation immediately before each individual + -- transaction for the normal subscription path. + let prepare event = do + oid <- freshOutboxId + envelope <- freshIntegrationEvent producer (draft & #sourceEventId ?~ event ^. #eventId & #sourceGlobalPosition ?~ event ^. #globalPosition) + pure (oid, envelope) + if batch + then do + messages <- forM recorded prepare + Store.runTransaction (traverse_ (uncurry enqueueIntegrationEventTx) messages) + else forM_ recorded $ \event -> do + message <- prepare event + Store.runTransaction (uncurry enqueueIntegrationEventTx message) + case result of + Left err -> fail (show err) + Right () -> pure () + isInserted ProducerInserted {} = True + isInserted _ = False + isDuplicate ProducerDuplicateIdentical {} = True + isDuplicate _ = False + +producer :: IntegrationProducer () +producer = IntegrationProducer "bench-producer" "bench.outbox" "msg" (\_ _ -> Just draft) + +draft :: IntegrationEventDraft +draft = + IntegrationEventDraft + { destination = "bench.outbox.events.v1", + key = Just "key", + eventType = "BenchEvent", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = Nothing, + sourceEventId = Nothing, + sourceGlobalPosition = Nothing, + payloadBytes = BS.replicate 1024 65, + occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + causationId = Nothing, + correlationId = Nothing, + traceContext = Nothing, + attributes = Nothing + } + +sourceEvent :: Int -> Int -> RecordedEvent +sourceEvent generation i = + RecordedEvent + { eventId = EventId (UUID.fromWords 0 (fromIntegral generation) 0 (fromIntegral i)), + eventType = EventType "BenchEvent", + streamVersion = StreamVersion (fromIntegral i), + globalPosition = GlobalPosition (fromIntegral i), + originalStreamId = StreamId 1, + originalVersion = StreamVersion (fromIntegral i), + payload = Aeson.Null, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing, + createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + } + +-- Force both identifiers, including the UUID projection, in the pure benchmark. +identityText :: ProducerEventKey -> (Text, Text) +identityText key = + let identity = deriveProducerIdentity producer key + in (UUID.toText (unOutboxId (identity ^. #outboxId)), identity ^. #messageId) diff --git a/keiro.cabal b/keiro.cabal --- a/keiro.cabal +++ b/keiro.cabal @@ -1,36 +1,48 @@ -cabal-version: 3.0 -name: keiro -version: 0.16.0.0 -synopsis: Event sourcing framework and workflow engine +cabal-version: 3.0 +name: keiro +version: 0.17.0.0 +synopsis: Event sourcing framework and workflow engine description: A library that composes kiroku, keiki, and shibuya into an event-sourcing and workflow-orchestration framework. -license: BSD-3-Clause -license-file: LICENSE -author: Nadeem Bitar -maintainer: nadeem@gmail.com -copyright: 2026 Nadeem Bitar -category: Control -homepage: https://github.com/shinzui/keiro#readme -bug-reports: https://github.com/shinzui/keiro/issues -build-type: Simple -tested-with: GHC >=9.12 && <9.13 +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Control +homepage: https://github.com/shinzui/keiro#readme +bug-reports: https://github.com/shinzui/keiro/issues +build-type: Simple +tested-with: ghc >=9.12 && <9.13 extra-doc-files: CHANGELOG.md README.md source-repository head - type: git + type: git location: https://github.com/shinzui/keiro.git +flag reaction-hydration-probe + description: + Emit opt-in stderr markers for process-reaction saga hydration and witness recovery + + manual: True + default: False + common warnings ghc-options: - -Wall -Wcompat -Widentities -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints common shared - default-language: GHC2024 + default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields @@ -41,8 +53,8 @@ PackageImports library - import: warnings, shared - autogen-modules: Paths_keiro + import: warnings, shared + autogen-modules: Paths_keiro exposed-modules: Keiro Keiro.Command @@ -52,14 +64,17 @@ Keiro.DeadLetter.Schema Keiro.DeterministicId Keiro.Inbox + Keiro.Inbox.Delegated Keiro.Inbox.Kafka Keiro.Inbox.Schema Keiro.Inbox.Types Keiro.Outbox + Keiro.Outbox.Identity Keiro.Outbox.Kafka Keiro.Outbox.Schema Keiro.Outbox.Types Keiro.ProcessManager + Keiro.ProcessManager.Reaction Keiro.Projection Keiro.Projection.Catalog Keiro.Projection.Catalog.Operations @@ -96,6 +111,8 @@ Keiro.Workflow.Snapshot Keiro.Workflow.Types + if flag(reaction-hydration-probe) + cpp-options: -DKEIRO_REACTION_HYDRATION_PROBE other-modules: Keiro.Command.Domain Keiro.Outbox.Rejection @@ -115,59 +132,59 @@ reexported-modules: keiro-core:Keiro.Codec, keiro-core:Keiro.Codec.IdDomain, + keiro-core:Keiro.Codec.Nominal, keiro-core:Keiro.Codec.Structural, keiro-core:Keiro.Codec.Structural.Generic, - keiro-core:Keiro.Codec.Nominal, keiro-core:Keiro.EventStream, keiro-core:Keiro.EventStream.Validate, keiro-core:Keiro.Integration.Event, keiro-core:Keiro.Prelude, keiro-core:Keiro.Snapshot.Policy, - keiro-core:Keiro.Stream + keiro-core:Keiro.Stream, - hs-source-dirs: src + hs-source-dirs: src build-depends: - , aeson >=2.2.2 && <2.3 - , aeson-casing >=0.2 && <0.3 - , base >=4.21 && <5 - , base16-bytestring >=1.0.2 && <1.1 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.8 - , contravariant-extras >=0.3 && <0.4 - , cryptohash-sha256 >=0.11.102 && <0.12 - , deepseq >=1.5 && <1.6 - , effectful >=2.6 && <2.7 - , effectful-core >=2.6 && <2.7 - , generic-lens >=2.2 && <2.4 - , hasql >=1.10 && <1.11 - , hasql-pool >=1.2 && <1.5 - , hasql-transaction >=1.1 && <1.3 - , hs-opentelemetry-api >=1.0 && <1.1 - , hs-opentelemetry-propagator-w3c >=1.0 && <1.1 - , hs-opentelemetry-semantic-conventions >=1.40 && <2 - , keiki >=0.9 && <0.10 - , keiki-codec-json >=0.9 && <0.10 - , keiro-core ^>=0.16.0.0 - , kiroku-store >=0.8 && <0.9 - , lens >=5.2 && <5.4 - , mmzk-typeid >=0.7 && <0.8 - , random >=1.2.1 && <1.4 - , scientific >=0.3 && <0.4 - , shibuya-core ^>=0.9.0.0 - , stm >=2.5 && <2.6 - , streamly >=0.11 && <0.12 - , streamly-core >=0.3 && <0.4 - , text >=2.1 && <2.2 - , time >=1.12 && <1.15 - , unliftio-core >=0.2 && <0.3 - , uuid >=1.3 && <1.4 - , vector >=0.13 && <0.14 + aeson >=2.2.2 && <2.3, + aeson-casing >=0.2 && <0.3, + base >=4.21 && <5, + base16-bytestring >=1.0.2 && <1.1, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + contravariant-extras >=0.3 && <0.4, + cryptohash-sha256 >=0.11.102 && <0.12, + deepseq >=1.5 && <1.6, + effectful >=2.6 && <2.7, + effectful-core >=2.6 && <2.7, + generic-lens >=2.2 && <2.4, + hasql >=1.10 && <1.11, + hasql-pool >=1.2 && <1.5, + hasql-transaction >=1.1 && <1.3, + hs-opentelemetry-api >=1.0 && <1.1, + hs-opentelemetry-propagator-w3c >=1.0 && <1.1, + hs-opentelemetry-semantic-conventions >=1.40 && <2, + keiki >=0.9 && <0.10, + keiki-codec-json >=0.9 && <0.10, + keiro-core ^>=0.17.0.0, + kiroku-store >=0.8 && <0.9, + lens >=5.2 && <5.4, + mmzk-typeid >=0.7 && <0.8, + random >=1.2.1 && <1.4, + scientific >=0.3 && <0.4, + shibuya-core ^>=0.9.0.0, + stm >=2.5 && <2.6, + streamly >=0.11 && <0.12, + streamly-core >=0.3 && <0.4, + text >=2.1 && <2.2, + time >=1.12 && <1.15, + unliftio-core >=0.2 && <0.3, + uuid >=1.3 && <1.4, + vector >=0.13 && <0.14, test-suite keiro-test - import: warnings, shared - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs autogen-modules: Paths_keiro other-modules: CatalogEvolutionSpec @@ -180,68 +197,84 @@ PreCanonicalRecoverySpec PreimageSpec ProjectionReplaySpec + ReactionExample ReadModelSpec VersionedRebuildSpec VersionedTargetPostgresSpec - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + build-depends: - , aeson >=2.2 && <2.3 - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.8 - , contravariant-extras >=0.3 && <0.4 - , effectful >=2.6 && <2.7 - , effectful-core >=2.6 && <2.7 - , hasql >=1.10 && <1.11 - , hasql-pool >=1.2 && <1.5 - , hasql-transaction >=1.1 && <1.3 - , hs-opentelemetry-api >=1.0 && <1.1 - , hs-opentelemetry-exporter-in-memory >=1.0 && <1.1 - , hs-opentelemetry-propagator-w3c >=1.0 && <1.1 - , hs-opentelemetry-sdk >=1.0 && <1.1 - , hs-opentelemetry-semantic-conventions >=1.40 && <2 - , hspec >=2.11 - , keiki - , keiki-codec-json - , keiro - , keiro-test-support ^>=0.16.0.0 - , kiroku-store >=0.8 && <0.9 - , process >=1.6 && <1.7 - , shibuya-core ^>=0.9.0.0 - , stm >=2.5 && <2.6 - , streamly-core >=0.3 && <0.4 - , text >=2.1 && <2.2 - , time >=1.12 && <1.15 - , unliftio-core >=0.2 && <0.3 - , uuid >=1.3 && <1.4 - , vector >=0.13 && <0.14 + aeson >=2.2 && <2.3, + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + contravariant-extras >=0.3 && <0.4, + effectful >=2.6 && <2.7, + effectful-core >=2.6 && <2.7, + hasql >=1.10 && <1.11, + hasql-pool >=1.2 && <1.5, + hasql-transaction >=1.1 && <1.3, + hs-opentelemetry-api >=1.0 && <1.1, + hs-opentelemetry-exporter-in-memory >=1.0 && <1.1, + hs-opentelemetry-propagator-w3c >=1.0 && <1.1, + hs-opentelemetry-sdk >=1.0 && <1.1, + hs-opentelemetry-semantic-conventions >=1.40 && <2, + hspec >=2.11, + keiki, + keiki-codec-json, + keiro, + keiro-test-support ^>=0.17.0.0, + kiroku-store >=0.8 && <0.9, + process >=1.6 && <1.7, + shibuya-core ^>=0.9.0.0, + stm >=2.5 && <2.6, + streamly-core >=0.3 && <0.4, + text >=2.1 && <2.2, + time >=1.12 && <1.15, + unliftio-core >=0.2 && <0.3, + uuid >=1.3 && <1.4, + vector >=0.13 && <0.14, benchmark keiro-bench - import: warnings, shared - type: exitcode-stdio-1.0 + import: warnings, shared + type: exitcode-stdio-1.0 hs-source-dirs: bench - main-is: Main.hs - other-modules: ReadModelBench - ghc-options: -threaded -rtsopts -with-rtsopts=-N + main-is: Main.hs + other-modules: + InboxDelegatedBench + ProducerIdentityBench + ReadModelBench + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + build-depends: - , aeson >=2.2.2 && <2.3 - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.8 - , effectful >=2.6 && <2.7 - , hasql >=1.10 && <1.11 - , hasql-transaction >=1.1 && <1.3 - , hs-opentelemetry-api >=1.0 && <1.1 - , hs-opentelemetry-sdk >=1.0 && <1.1 - , keiki >=0.9 && <0.10 - , keiro - , keiro-core ^>=0.16.0.0 - , keiro-test-support ^>=0.16.0.0 - , kiroku-store >=0.8 && <0.9 - , shibuya-core ^>=0.9.0.0 - , streamly-core >=0.3 && <0.4 - , tasty-bench >=0.4 - , text >=2.1 && <2.2 - , time >=1.12 && <1.15 - , uuid >=1.3 && <1.4 + aeson >=2.2.2 && <2.3, + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + deepseq >=1.5 && <1.6, + directory >=1.3 && <1.4, + effectful >=2.6 && <2.7, + filepath >=1.4 && <1.6, + hasql >=1.10 && <1.11, + hasql-transaction >=1.1 && <1.3, + hs-opentelemetry-api >=1.0 && <1.1, + hs-opentelemetry-sdk >=1.0 && <1.1, + keiki >=0.9 && <0.10, + keiro, + keiro-core ^>=0.17.0.0, + keiro-test-support ^>=0.17.0.0, + kiroku-store >=0.8 && <0.9, + shibuya-core ^>=0.9.0.0, + streamly-core >=0.3 && <0.4, + tasty-bench >=0.4, + text >=2.1 && <2.2, + time >=1.12 && <1.15, + uuid >=1.3 && <1.4, diff --git a/src/Keiro/Command.hs b/src/Keiro/Command.hs --- a/src/Keiro/Command.hs +++ b/src/Keiro/Command.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | The command side of the framework: hydrate an aggregate, transduce, append. -- -- Running a command against an 'EventStream' follows one pipeline: @@ -89,6 +91,9 @@ import Control.Concurrent (threadDelay) import Control.Exception (displayException) import Data.Aeson qualified as Aeson +#ifdef KEIRO_REACTION_HYDRATION_PROBE +import Data.ByteString.Char8 qualified as ByteString.Char8 +#endif import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Data.Functor (($>)) import Data.Int (Int32) @@ -409,7 +414,35 @@ EventStream phi rs s ci co -> Stream (EventStream phi rs s ci co) -> Eff es (Either CommandError (Hydrated rs s)) +#ifdef KEIRO_REACTION_HYDRATION_PROBE hydrate options eventStream targetStream = + liftIO + ( ByteString.Char8.hPutStrLn stderr + ( LazyByteString.toStrict + ( Aeson.encode + ( Aeson.object + [ "marker" Aeson..= ("reaction-probe" :: Text), + "operation" Aeson..= ("hydrate" :: Text), + "stream" Aeson..= resolvedStreamName eventStream targetStream + ] + ) + ) + ) + ) + >> hydrateAfterProbe options eventStream targetStream +#else +hydrate options eventStream targetStream = + hydrateAfterProbe options eventStream targetStream +#endif + +hydrateAfterProbe :: + forall phi rs s ci co es. + (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) => + RunCommandOptions -> + EventStream phi rs s ci co -> + Stream (EventStream phi rs s ci co) -> + Eff es (Either CommandError (Hydrated rs s)) +hydrateAfterProbe options eventStream targetStream = snapshotSeed >>= \case Nothing -> hydrateFull options eventStream targetStream Just seed -> do diff --git a/src/Keiro/Inbox.hs b/src/Keiro/Inbox.hs --- a/src/Keiro/Inbox.hs +++ b/src/Keiro/Inbox.hs @@ -40,12 +40,16 @@ runInboxTransactionWithRetriesWith, runInboxTransactionWithRetriesKey, runInboxTransactionBatch, + runInboxDelegated, + runInboxDelegatedWithRetries, + runInboxDelegatedBatch, sampleInboxBacklog, ) where import Data.Map.Strict qualified as Map import Data.Maybe (listToMaybe, mapMaybe) +import Data.Set qualified as Set import Data.Text qualified as Text import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync) @@ -407,6 +411,117 @@ in if Map.member key seen then BatchDuplicate : go seen rest else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest + +-- | Run an integration handler whose downstream operation owns the durable +-- deduplication receipt. +-- +-- This wrapper computes the same policy key as the table-backed inbox, but it +-- performs no inbox reads or writes and requires no 'Store' effect. The handler +-- receives the computed key and must cover every protected effect with that +-- identity. A returned 'DelegatedOutcome' is the handler's assertion about the +-- downstream result; it is not independently verified by this wrapper. +-- +-- Synchronous and asynchronous exceptions both propagate. Use +-- 'runInboxDelegatedWithRetries' when synchronous failures should be classified +-- for a caller-owned retry ladder. +runInboxDelegated :: + forall a es. + (IOE :> es) => + Maybe KeiroMetrics -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) -> + Eff es (Either InboxError (InboxResult a)) +runInboxDelegated mMetrics policy event kafka handler = + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> do + result <- delegatedResult <$> handler dedupe event + recordInboxResult mMetrics Nothing result + pure (Right result) + +-- | Run delegated intake with an explicit, caller-owned retry position. +-- +-- At an attempt above the configured ceiling, the handler is not invoked and +-- the result is 'InboxPreviouslyFailed'. At or below the ceiling, synchronous +-- exceptions become 'InboxHandlerFailed' with the current attempt number; +-- asynchronous cancellation still propagates. Typed errors in the handler's +-- effect stack are not exceptions and must be handled by the caller. +runInboxDelegatedWithRetries :: + forall a es. + (IOE :> es) => + Maybe KeiroMetrics -> + DelegatedRetryContext -> + InboxDedupePolicy -> + IntegrationEvent -> + Maybe KafkaDeliveryRef -> + (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) -> + Eff es (Either InboxError (InboxResult a)) +runInboxDelegatedWithRetries mMetrics retryContext policy event kafka handler = + case dedupeKeyFor policy event kafka of + Left err -> pure (Left err) + Right dedupe -> do + let attemptLimit = delegatedRetryCeiling retryContext + attempt = delegatedRetryAttempt retryContext + result <- + if attempt > attemptLimit + then pure (InboxPreviouslyFailed Nothing) + else do + attempted <- trySync (handler dedupe event) + pure $ case attempted of + Right outcome -> delegatedResult outcome + Left err -> InboxHandlerFailed (Text.pack (displayException err)) attempt + recordInboxResult mMetrics (Just attemptLimit) result + pure (Right result) + +-- | Process a bounded chunk of delegated deliveries sequentially. +-- +-- Successful identities are remembered only for this call, keyed by source and +-- dedupe key. A later occurrence of a successful identity is classified as a +-- duplicate without invoking the handler. Policy errors and synchronous +-- handler exceptions are returned per item and do not suppress a later retry of +-- the same identity. Async cancellation propagates immediately. This function +-- creates no threads or transactions and retains O(n) results and keys for an +-- input chunk of size n. +runInboxDelegatedBatch :: + forall a es. + (IOE :> es) => + Maybe KeiroMetrics -> + InboxDedupePolicy -> + [(IntegrationEvent, Maybe KafkaDeliveryRef)] -> + (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) -> + Eff es [Either InboxError (InboxResult a)] +runInboxDelegatedBatch mMetrics policy deliveries handler = + go Set.empty [] deliveries + where + go _ results [] = pure (reverse results) + go seen results ((event, kafka) : rest) = + case dedupeKeyFor policy event kafka of + Left err -> go seen (Left err : results) rest + Right dedupe -> do + let identity = (event ^. #source, dedupe) + if Set.member identity seen + then do + recordInboxResult mMetrics Nothing InboxDuplicate + go seen (Right InboxDuplicate : results) rest + else do + attempted <- trySync (handler dedupe event) + case attempted of + Left err -> do + let result = InboxHandlerFailed (Text.pack (displayException err)) 1 + recordInboxResult mMetrics Nothing result + go seen (Right result : results) rest + Right outcome -> do + let result = delegatedResult outcome + seen' = Set.insert identity seen + recordInboxResult mMetrics Nothing result + seen' `seq` go seen' (Right result : results) rest + +delegatedResult :: DelegatedOutcome a -> InboxResult a +delegatedResult = \case + DelegatedFresh value -> InboxProcessed value + DelegatedDuplicate -> InboxDuplicate -- | Count the inbox backlog and record the gauge when metrics are enabled. -- diff --git a/src/Keiro/Inbox/Delegated.hs b/src/Keiro/Inbox/Delegated.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Inbox/Delegated.hs @@ -0,0 +1,122 @@ +-- | Safe adapters for handlers used with delegated-idempotence inbox intake. +-- +-- The wrappers in "Keiro.Inbox" deliberately accept any effectful handler, so +-- they cannot prove that its complete operation is idempotent. This module +-- supplies narrower adapters for one aggregate command or one already-resolved +-- process-manager command result. Both require a durable event receipt and +-- refuse to acknowledge failures or successful commands that appended no event. +module Keiro.Inbox.Delegated + ( delegatedEventId, + DelegatedCommandError (..), + delegatedCommand, + delegatedFromPMCommand, + ) +where + +import Data.ByteString qualified as ByteString +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.UUID.V5 qualified as UUID.V5 +import Effectful (Eff, (:>)) +import Keiro.Command (CommandError, CommandResult, RunCommandOptions) +import Keiro.DeterministicId (identitySeedBytes) +import Keiro.Inbox.Types (DelegatedOutcome (..)) +import Keiro.Prelude +import Keiro.ProcessManager (PMCommandResult (..), dispatchDeduplicatedCommand) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Types (EventId (..), StreamName (..)) + +-- | Derive the permanent first-event receipt for one delegated command. +-- +-- The identity contains a version tag followed by consumer, integration source, +-- inbox dedupe key, resolved target stream, and stable operation name. Every +-- field is prefixed with its UTF-8 byte length, making boundaries unambiguous +-- even for empty, Unicode, or delimiter-containing values. These inputs and the +-- version-1 recipe are replay identity and must remain stable for the full +-- redelivery horizon. +delegatedEventId :: Text -> Text -> Text -> StreamName -> Text -> EventId +delegatedEventId consumer source dedupe (StreamName target) operation = + EventId + ( UUID.V5.generateNamed + UUID.V5.namespaceURL + ( identitySeedBytes + ( Text.concat + ( encodeField + <$> [ "keiro/inbox-delegated/1", + consumer, + source, + dedupe, + target, + operation + ] + ) + ) + ) + ) + where + encodeField field = + Text.pack (show (ByteString.length (Text.Encoding.encodeUtf8 field))) + <> ":" + <> field + +-- | Why a command cannot serve as a delegated-idempotence receipt. +data DelegatedCommandError + = -- | The command failed; the target name is retained for retry and diagnostics. + DelegatedCommandFailed !StreamName !CommandError + | -- | The command succeeded without appending an event, so it left no durable + -- receipt for this intake identity. + DelegatedCommandWithoutReceipt !StreamName + deriving stock (Generic, Eq, Show) + +-- | Protect one atomic command append with a deterministic first-event receipt. +-- +-- The adapter probes @markerId@ in @targetStream@ before invoking the callback, +-- preventing hydration or dispatch on a confirmed replay. It replaces the +-- options' event-id list with the singleton marker, then passes those prepared +-- options to the callback. The callback must use the supplied options and target, +-- perform exactly one atomic append, and include all protected SQL, projection, +-- and outbox work in that append transaction. +-- +-- A positive append is fresh; a preflight hit or a concurrently confirmed append +-- is duplicate. A zero-event success and every unconfirmed command error remain +-- typed failures. In particular, callers must inspect 'Left' and apply their +-- retry or dead-letter policy; wrapping this whole result in 'DelegatedFresh' +-- would acknowledge a failed operation. +delegatedCommand :: + forall target es. + (Store :> es) => + RunCommandOptions -> + StreamName -> + EventId -> + (RunCommandOptions -> Eff es (Either CommandError (CommandResult target))) -> + Eff es (Either DelegatedCommandError (DelegatedOutcome (CommandResult target))) +delegatedCommand baseOptions targetStream markerId dispatch = + dispatchDeduplicatedCommand + preparedOptions + targetStream + (markerId :| []) + (const (Right DelegatedDuplicate)) + (Left . DelegatedCommandFailed targetStream) + classifySuccess + (dispatch preparedOptions) + where + preparedOptions = baseOptions & #eventIds .~ [markerId] + classifySuccess result + | result ^. #eventsAppended > 0 = Right (DelegatedFresh result) + | otherwise = Left (DelegatedCommandWithoutReceipt targetStream) + +-- | Adapt one process-manager command result after its deterministic dispatch. +-- +-- This is valid only for a single dispatch whose command identity already +-- absorbs the intake identity. It does not prove that an arbitrary multi-command +-- process-manager reaction completed. +delegatedFromPMCommand :: + StreamName -> + PMCommandResult target -> + Either DelegatedCommandError (DelegatedOutcome (CommandResult target)) +delegatedFromPMCommand resolvedTarget = \case + PMCommandDuplicate _ -> Right DelegatedDuplicate + PMCommandAppended result + | result ^. #eventsAppended > 0 -> Right (DelegatedFresh result) + | otherwise -> Left (DelegatedCommandWithoutReceipt resolvedTarget) + PMCommandFailed failedTarget err -> Left (DelegatedCommandFailed failedTarget err) 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 @@ -9,9 +9,15 @@ module Keiro.Inbox.Types ( RetryDelay (..), InboxDedupePolicy (..), + InboxIdempotence (..), InboxPersistence (..), InboxStatus (..), InboxResult (..), + DelegatedOutcome (..), + DelegatedRetryContext, + mkDelegatedRetryContext, + delegatedRetryCeiling, + delegatedRetryAttempt, InboxError (..), InboxRow (..), KafkaDeliveryRef (..), @@ -56,6 +62,16 @@ | CustomDedupeKey !Text deriving stock (Generic, Eq, Show) +-- | Where an integration consumer keeps its durable deduplication receipt. +-- +-- 'IdempotenceInboxTable' uses Keiro's @keiro_inbox@ table. In +-- 'IdempotenceDelegated' mode the supplied handler owns the receipt and Keiro +-- performs no inbox reads or writes. +data InboxIdempotence + = IdempotenceInboxTable + | IdempotenceDelegated + deriving stock (Generic, Eq, Show) + -- | How much of the integration-event envelope the inbox persists on the -- success path. -- @@ -84,8 +100,10 @@ -- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'. -- -- * 'InboxProcessed a' — first delivery; handler ran and returned @a@. --- * 'InboxDuplicate' — a previous delivery already completed; handler not --- run. +-- * 'InboxDuplicate' — a previous delivery already completed. Table-backed +-- intake does not run the handler; delegated intake may run it so the +-- downstream state machine can confirm the duplicate, while its protected +-- effects remain unchanged. -- * 'InboxInProgress' — a previous attempt is currently in-flight, or a -- legacy @processing@ row was read. Current single-transaction intake -- does not commit @processing@ rows. Treat as transient. @@ -98,6 +116,42 @@ | InboxPreviouslyFailed !(Maybe Text) | InboxHandlerFailed !Text !Int deriving stock (Generic, Eq, Show) + +-- | The result asserted by a delegated-idempotence handler. +-- +-- 'DelegatedFresh' means the handler durably completed the protected operation +-- for the first time. 'DelegatedDuplicate' means that same durable operation +-- was already complete. This value is an explicit assertion by the caller; +-- Keiro cannot prove that arbitrary effects were covered by the downstream +-- receipt. +data DelegatedOutcome a + = DelegatedFresh !a + | DelegatedDuplicate + deriving stock (Generic, Eq, Show) + +-- | Validated, caller-owned retry position for delegated intake. +-- +-- The first value supplied to 'mkDelegatedRetryContext' is the positive attempt +-- ceiling and the second is the positive, one-based current attempt. Attempts +-- above the ceiling are valid: they classify a redelivery as +-- 'InboxPreviouslyFailed' without invoking the handler. +data DelegatedRetryContext = DelegatedRetryContext !Int !Int + deriving stock (Eq, Show) + +-- | Validate a retry ceiling and one-based current attempt. +mkDelegatedRetryContext :: Int -> Int -> Either Text DelegatedRetryContext +mkDelegatedRetryContext attemptLimit attempt + | attemptLimit <= 0 = Left "delegated retry ceiling must be positive" + | attempt <= 0 = Left "delegated retry attempt must be positive" + | otherwise = Right (DelegatedRetryContext attemptLimit attempt) + +-- | Read the configured attempt ceiling from a validated context. +delegatedRetryCeiling :: DelegatedRetryContext -> Int +delegatedRetryCeiling (DelegatedRetryContext attemptLimit _) = attemptLimit + +-- | Read the one-based current attempt from a validated context. +delegatedRetryAttempt :: DelegatedRetryContext -> Int +delegatedRetryAttempt (DelegatedRetryContext _ attempt) = attempt -- | Errors surfaced by the inbox wrapper that originate from the inbox -- itself rather than from the supplied handler. diff --git a/src/Keiro/Outbox.hs b/src/Keiro/Outbox.hs --- a/src/Keiro/Outbox.hs +++ b/src/Keiro/Outbox.hs @@ -6,9 +6,8 @@ -- -- * The canonical 'IntegrationProducer' helper maps durable private events -- to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues --- one outbox row per mapped event. It mints @messageId@ as a prefixed --- UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable --- across publish retries. +-- one outbox row per mapped event. Versioned source-event coordinates +-- derive both IDs deterministically across producer and publication retries. -- * 'enqueueOutboxTx' is the inline escape hatch for sagas and process -- managers that need to emit an integration event without an intermediate -- private domain event. It runs inside the caller's @@ -32,6 +31,9 @@ module Keiro.Outbox ( -- * Re-exports module Keiro.Outbox.Types, + module Keiro.Outbox.Identity, + deriveProducerIdentity, + recordProducerEnqueueOutcome, -- * Storage primitives (transport-neutral) enqueueOutboxTx, @@ -55,6 +57,7 @@ IntegrationEventDraft (..), mkIntegrationProducer, mintIntegrationEvent, + freshIntegrationEvent, draftToEvent, enqueueProducerEventTx, @@ -71,6 +74,7 @@ import Data.Text qualified as Text import Data.TypeID qualified as TypeID import Data.UUID.V7 qualified as V7 +import Data.Word (Word32) import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync) import Keiro.Integration.Event @@ -79,6 +83,7 @@ SchemaReference, TraceContext, ) +import Keiro.Outbox.Identity import Keiro.Outbox.Kafka (outboxRowToKafkaRecord) import Keiro.Outbox.Schema import Keiro.Outbox.Types @@ -87,6 +92,7 @@ ( KeiroMetrics, recordOutboxBacklog, recordOutboxDeadlettered, + recordOutboxIdentityConflict, recordOutboxPublished, recordOutboxReclaimed, recordOutboxRejected, @@ -95,7 +101,7 @@ ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction) -import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent) +import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent (..)) import OpenTelemetry.Attributes.Key (AttributeKey (..), unkey) import OpenTelemetry.SemanticConventions (error_type) import OpenTelemetry.Trace.Core (SpanStatus (..), addAttribute, setStatus) @@ -133,18 +139,16 @@ -- -- A service running 'IntegrationProducer' reads its private event stream, -- decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for --- each 'Just' result writes one 'keiro_outbox' row. The helper mints --- @messageId@ on each insert so the id is stable across publish retries. +-- each 'Just' result writes one 'keiro_outbox' row. Source-event coordinates +-- derive stable IDs across enqueue and publication retries. -- -- * 'name' — subscription name used to checkpoint the producer's cursor -- in the @subscriptions@ table. -- * 'source' — value written into @keiro_outbox.source@; identifies the -- producing bounded context. --- * 'messageIdPrefix' — TypeID prefix used when minting @messageId@. --- Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@). --- Prefer constructing producers with 'mkIntegrationProducer'; an invalid --- prefix passed directly to 'IntegrationProducer' raises when the first --- message id is minted. +-- * 'messageIdPrefix' — non-empty namespace, validated using TypeID prefix +-- syntax. The resulting deterministic message ID is opaque text, not a TypeID. +-- Prefer 'mkIntegrationProducer'; direct record construction bypasses validation. -- * 'mapEvent' — pure mapper from a private 'RecordedEvent' and its -- decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing' -- skips the event without enqueuing a row. @@ -162,22 +166,22 @@ -- | Validate an integration producer before starting its subscription. mkIntegrationProducer :: IntegrationProducer e -> Either IntegrationProducerConfigError (IntegrationProducer e) -mkIntegrationProducer producer = - case TypeID.checkPrefix (producer ^. #messageIdPrefix) of - Nothing -> Right producer - Just err -> - Left - ( InvalidMessageIdPrefix - (producer ^. #messageIdPrefix) - (Text.pack (show err)) - ) +mkIntegrationProducer producer + | Text.null (producer ^. #messageIdPrefix) = Left (InvalidMessageIdPrefix "" "namespace must not be empty") + | otherwise = case TypeID.checkPrefix (producer ^. #messageIdPrefix) of + Nothing -> Right producer + Just err -> + Left + ( InvalidMessageIdPrefix + (producer ^. #messageIdPrefix) + (Text.pack (show err)) + ) -- | Everything in 'IntegrationEvent' except 'messageId' and 'source' — --- those are filled in by 'mintIntegrationEvent' from the producer --- configuration and the freshly minted TypeID. +-- those are filled by 'enqueueProducerEventTx' using deterministic identity. -- -- @sourceEventId@ and @sourceGlobalPosition@ default to the values on the --- underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that +-- underlying 'RecordedEvent' (see 'enqueueProducerEventTx'); a mapper that -- needs to override them can replace the draft fields directly. data IntegrationEventDraft = IntegrationEventDraft { destination :: !Text, @@ -205,7 +209,13 @@ IntegrationProducer e -> IntegrationEventDraft -> Eff es IntegrationEvent -mintIntegrationEvent producer draft = do +mintIntegrationEvent = freshIntegrationEvent +{-# DEPRECATED mintIntegrationEvent "Use enqueueProducerEventTx for replay-safe producer identity, or freshIntegrationEvent for explicitly fresh envelopes." #-} + +-- | Generate an explicitly fresh envelope. Persist it before retrying; this +-- helper alone provides no producer replay identity or provenance defaulting. +freshIntegrationEvent :: (IOE :> es) => IntegrationProducer e -> IntegrationEventDraft -> Eff es IntegrationEvent +freshIntegrationEvent producer draft = do typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix)) pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft) @@ -231,33 +241,39 @@ attributes = draft ^. #attributes } --- | Enqueue one drafted producer event inside an existing transaction. --- --- This is the primitive a subscription worker calls per event. It mints a --- fresh @messageId@ (TypeID), constructs the full envelope, and inserts --- the row. The caller supplies the 'OutboxId' so retries from a known --- subscription cursor coalesce on @(source, message_id)@. --- --- The TypeID is minted before the insert; if the transaction rolls back --- the message id is discarded (no observable effect) and the next attempt --- mints a different id. Idempotency at the row level relies on a stable --- 'OutboxId', not the minted message id. --- --- Ordering caveat: @created_at@ records transaction-start time. Under --- 'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same --- key/source can commit in the opposite order and are therefore best-effort --- unless the caller serializes them. The canonical producer subscription does --- serialize same-key enqueues. +-- | Observe a completed enqueue attempt outside its transaction. Invoke once +-- after the runner returns; SQL serialization retries do not multiply metrics. +recordProducerEnqueueOutcome :: (MonadIO m) => Maybe KeiroMetrics -> ProducerEnqueueOutcome -> m () +recordProducerEnqueueOutcome metrics = \case + ProducerIdentityConflict {} -> recordOutboxIdentityConflict metrics 1 + _ -> pure () + +-- | Pure identity for one stable producer/source-event coordinate. +deriveProducerIdentity :: IntegrationProducer e -> ProducerEventKey -> ProducerIdentity +deriveProducerIdentity producer = deriveIdentity (producer ^. #source) (producer ^. #name) (producer ^. #messageIdPrefix) + +-- | Enqueue a source event emission. Use index zero for today's single-draft +-- mapper. Missing source provenance defaults from the recorded event. On a +-- conflict, callers should condemn the surrounding checkpoint transaction and +-- report the returned field classes after the transaction completes. +-- Suppression is bounded by outbox retention; wire identity survives GC. enqueueProducerEventTx :: - forall e es. - (IOE :> es) => IntegrationProducer e -> - OutboxId -> + RecordedEvent -> + Word32 -> IntegrationEventDraft -> - Eff es (Tx.Transaction ()) -enqueueProducerEventTx producer outboxId draft = do - event <- mintIntegrationEvent producer draft - pure (enqueueOutboxTx (OutboxMessage {outboxId, event})) + Tx.Transaction ProducerEnqueueOutcome +enqueueProducerEventTx producer recorded emission draft = + enqueueProducerOutboxTx identity event + where + identity = deriveProducerIdentity producer (ProducerEventKey (recorded ^. #eventId) emission) + withProvenance = + draft + & #sourceEventId + .~ ((draft ^. #sourceEventId) <|> Just (recorded ^. #eventId)) + & #sourceGlobalPosition + .~ ((draft ^. #sourceGlobalPosition) <|> Just (recorded ^. #globalPosition)) + event = normalizeProducerEvent (draftToEvent (producer ^. #source) (identity ^. #messageId) withProvenance) -- --------------------------------------------------------------------------- -- Publisher worker diff --git a/src/Keiro/Outbox/Identity.hs b/src/Keiro/Outbox/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Outbox/Identity.hs @@ -0,0 +1,139 @@ +-- | Frozen version-1 producer identities and canonical envelope comparisons. +module Keiro.Outbox.Identity + ( ProducerEventKey (..), + ProducerIdentity (..), + ProducerEnqueueOutcome (..), + ConflictField (..), + producerIdentityBytes, + deriveIdentity, + producerContentDigest, + differingContentFields, + normalizeProducerEvent, + ) +where + +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.Bits ((.&.), (.|.)) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Builder qualified as Builder +import Data.ByteString.Lazy qualified as Lazy +import Data.Text.Encoding qualified as TE +import Data.Time (UTCTime (..)) +import Data.UUID qualified as UUID +import Data.Word (Word16, Word32) +import Keiro.Integration.Event +import Keiro.Outbox.Types (OutboxId (..)) +import Keiro.Prelude +import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest) +import Kiroku.Store.Types (EventId (..)) + +data ProducerEventKey = ProducerEventKey + { sourceEventId :: !EventId, + emissionIndex :: !Word32 + } + deriving stock (Generic, Eq, Show) + +data ProducerIdentity = ProducerIdentity + { outboxId :: !OutboxId, + messageId :: !Text, + derivationVersion :: !Word16 + } + deriving stock (Generic, Eq, Show) + +-- | Field classes only: no payload or metadata values appear in conflicts. +data ConflictField + = IdentityField + | RoutingField + | SchemaField + | PayloadField + | OccurredAtField + | CausalField + | TraceField + | AttributesField + | ProvenanceField + deriving stock (Generic, Eq, Ord, Show) + +-- | Transaction-local result. Insertion does not assert that the surrounding +-- transaction committed; later checkpoint failure can still roll it back. +data ProducerEnqueueOutcome + = ProducerInserted !ProducerIdentity + | ProducerDuplicateIdentical !ProducerIdentity + | ProducerIdentityConflict !ProducerIdentity !(NonEmpty ConflictField) + deriving stock (Generic, Eq, Show) + +-- | Each field has an unsigned 64-bit big-endian byte length. Fields are +-- domain, version (two bytes), UTF-8 source/name, source UUID (16 network-order +-- bytes), and emission index (four bytes). The namespace labels the message ID; +-- changing it intentionally conflicts with the unchanged outbox UUID. +producerIdentityBytes :: Text -> Text -> ProducerEventKey -> BS.ByteString +producerIdentityBytes source name key = + Lazy.toStrict . Builder.toLazyByteString $ + field "keiro.producer.outbox" + <> Builder.word64BE 2 + <> Builder.word16BE 1 + <> field (TE.encodeUtf8 source) + <> field (TE.encodeUtf8 name) + <> Builder.word64BE 16 + <> Builder.word32BE a + <> Builder.word32BE b + <> Builder.word32BE c + <> Builder.word32BE d + <> Builder.word64BE 4 + <> Builder.word32BE (key ^. #emissionIndex) + where + EventId uuid = key ^. #sourceEventId + (a, b, c, d) = UUID.toWords uuid + field value = Builder.word64BE (fromIntegral (BS.length value)) <> Builder.byteString value + +-- | SHA-256 of the canonical tuple. UUID uses the first 128 bits with RFC +-- variant and version 8 bits set. Message ID is namespace <> "_v1_" <> full +-- lowercase SHA-256 hex. No clock, random generator, or process state is read. +deriveIdentity :: Text -> Text -> Text -> ProducerEventKey -> ProducerIdentity +deriveIdentity source name namespace key = + ProducerIdentity + { outboxId = OutboxId (UUID.fromWords (word 0) ((word 4 .&. 0xffff0fff) .|. 0x8000) ((word 8 .&. 0x3fffffff) .|. 0x80000000) (word 12)), + messageId = namespace <> "_v1_" <> TE.decodeUtf8 (Base16.encode digest), + derivationVersion = 1 + } + where + digest = SHA256.hash (producerIdentityBytes source name key) + word offset = BS.foldl' (\acc byte -> acc * 256 + fromIntegral byte) 0 (BS.take 4 (BS.drop offset digest)) + +-- | PostgreSQL stores whole microseconds. Normalize before writing so the +-- canonical timestamp is unchanged by the database round trip. +normalizeProducerEvent :: IntegrationEvent -> IntegrationEvent +normalizeProducerEvent event = event & #occurredAt .~ UTCTime day (fromRational (fromInteger micros / 1000000)) + where + UTCTime day time = event ^. #occurredAt + micros = floor (toRational time * 1000000) :: Integer + +-- | RFC 8785 JSON of a fixed ordered list of field classes. Payload stays +-- byte-exact (hex); attributes are structured canonical JSON, not encoded text. +producerContentDigest :: IntegrationEvent -> Text +producerContentDigest = replayDigest . toJSON . fmap snd . contentFields + +differingContentFields :: IntegrationEvent -> IntegrationEvent -> [ConflictField] +differingContentFields a b + -- Exact envelope equality implies canonical equality. This avoids hex/JSON + -- allocation for the usual identical replay; canonical comparison still + -- handles equivalent structured values and wire-equivalent optional schemas. + | normalizeProducerEvent a == normalizeProducerEvent b = [] + | otherwise = [field | ((field, x), (_, y)) <- zip (contentFields a) (contentFields b), canonicalJsonBytes x /= canonicalJsonBytes y] + +contentFields :: IntegrationEvent -> [(ConflictField, Value)] +contentFields original = + [ (IdentityField, headers [headerMessageId, headerSource]), + (RoutingField, toJSON (event ^. #destination, event ^. #key)), + (SchemaField, headers [headerEventType, headerSchemaVersion, headerContentType, headerSchemaRegistry, headerSchemaSubject, headerSchemaVersionRef, headerSchemaId, headerSchemaFingerprint]), + (PayloadField, toJSON (TE.decodeUtf8 (Base16.encode (event ^. #payloadBytes)))), + (OccurredAtField, headers [headerOccurredAt]), + (CausalField, headers [headerCausationId, headerCorrelationId]), + (TraceField, headers [headerTraceParent, headerTraceState]), + (AttributesField, toJSON (maybe [] pure (event ^. #attributes))), + (ProvenanceField, headers [headerSourceEventId, headerSourceGlobalPosition]) + ] + where + event = normalizeProducerEvent original + allHeaders = integrationHeaders event + headers names = toJSON [(name, lookup name allHeaders) | name <- names] 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 @@ -7,6 +7,7 @@ -- ('Keiro.Outbox.Kafka') consume these primitives. module Keiro.Outbox.Schema ( enqueueOutboxTx, + enqueueProducerOutboxTx, claimOutboxBatch, requeueStuckOutbox, markOutboxSent, @@ -27,6 +28,7 @@ import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) import Data.ByteString (ByteString) import Data.Functor.Contravariant ((>$<)) +import Data.List.NonEmpty qualified as NE import Data.Time.Clock (NominalDiffTime, addUTCTime) import Data.UUID (UUID) import Effectful (Eff, (:>)) @@ -34,12 +36,13 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiro.Integration.Event - ( IntegrationEvent (..), + ( IntegrationContentType (..), + IntegrationEvent (..), SchemaReference (..), TraceContext (..), contentTypeText, - parseContentType, ) +import Keiro.Outbox.Identity import Keiro.Outbox.Rejection (PublishRejection (..)) import Keiro.Outbox.Types import Keiro.Prelude @@ -64,6 +67,33 @@ enqueueOutboxTx message = Tx.statement (toEncodedRow message) enqueueOutboxStmt +-- | Insert or compare both unique identities without mutating a retained row. +-- A separate statement sees a concurrent winner at READ COMMITTED. Higher +-- isolation levels require the caller's normal serialization retry policy. +enqueueProducerOutboxTx :: ProducerIdentity -> IntegrationEvent -> Tx.Transaction ProducerEnqueueOutcome +enqueueProducerOutboxTx identity event = do + inserted <- Tx.statement (toEncodedRow (OutboxMessage (identity ^. #outboxId) event)) enqueueProducerStmt + if inserted + then pure (ProducerInserted identity) + else do + rows <- Tx.statement (unOutboxId (identity ^. #outboxId), event ^. #source, event ^. #messageId) producerConflictStmt + case rows of + [] -> enqueueProducerOutboxTx identity event -- GC won between insert and read. + _ -> case NE.nonEmpty (concatMap differences rows) of + Nothing -> pure (ProducerDuplicateIdentical identity) + Just fields -> pure (ProducerIdentityConflict identity fields) + where + differences row = + [IdentityField | row ^. #outboxId /= identity ^. #outboxId] + <> differingContentFields event (row ^. #event) + +producerConflictStmt :: Statement (UUID, Text, Text) [OutboxRow] +producerConflictStmt = + preparable + (selectAllSql <> " WHERE outbox_id = $1 OR (source = $2 AND message_id = $3) ORDER BY outbox_id FOR UPDATE") + (contrazip3 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text))) + (D.rowList outboxRowDecoder) + -- | Read a single outbox row by id. Used by tests and inspection tooling. lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow) lookupOutbox outboxId = @@ -372,40 +402,42 @@ -- --------------------------------------------------------------------------- enqueueOutboxStmt :: Statement EncodedRow () -enqueueOutboxStmt = - preparable - """ - INSERT INTO keiro.keiro_outbox - ( outbox_id - , message_id - , source - , destination - , message_key - , event_type - , schema_version - , content_type - , schema_registry - , schema_subject - , schema_version_ref - , schema_id - , schema_fingerprint - , source_event_id - , source_global_position - , causation_id - , correlation_id - , traceparent - , tracestate - , payload_bytes - , attributes - , occurred_at - ) - VALUES - ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22) - ON CONFLICT (source, message_id) DO NOTHING - """ - encodedRowEncoder - D.noResult +enqueueOutboxStmt = preparable (enqueueOutboxSql <> " ON CONFLICT (source, message_id) DO NOTHING") encodedRowEncoder D.noResult +enqueueProducerStmt :: Statement EncodedRow Bool +enqueueProducerStmt = preparable (enqueueOutboxSql <> " ON CONFLICT DO NOTHING") encodedRowEncoder ((> 0) <$> D.rowsAffected) + +enqueueOutboxSql :: Text +enqueueOutboxSql = + """ + INSERT INTO keiro.keiro_outbox + ( outbox_id + , message_id + , source + , destination + , message_key + , event_type + , schema_version + , content_type + , schema_registry + , schema_subject + , schema_version_ref + , schema_id + , schema_fingerprint + , source_event_id + , source_global_position + , causation_id + , correlation_id + , traceparent + , tracestate + , payload_bytes + , attributes + , occurred_at + ) + VALUES + ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22) + """ + claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow] claimStmt policy = preparable @@ -871,7 +903,7 @@ key = raw ^. #key, eventType = raw ^. #eventType, schemaVersion = raw ^. #schemaVersion, - contentType = parseContentType (raw ^. #contentType), + contentType = if raw ^. #contentType == "application/json" then ApplicationJson else OtherContentType (raw ^. #contentType), schemaReference, sourceEventId = raw ^. #sourceEventId, sourceGlobalPosition = raw ^. #sourceGlobalPosition, diff --git a/src/Keiro/ProcessManager.hs b/src/Keiro/ProcessManager.hs --- a/src/Keiro/ProcessManager.hs +++ b/src/Keiro/ProcessManager.hs @@ -230,8 +230,10 @@ -- | What a process manager decides to do for one input event: advance its own -- state with 'command', dispatch zero or more target 'commands', and schedule --- zero or more 'timers'. All three are applied atomically with crash-safe --- idempotency by 'runProcessManagerOnce'. +-- zero or more 'timers'. The manager-state append and timer writes share one +-- transaction. Each target command then commits in its own transaction, so a +-- later failure cannot roll back an earlier target append; deterministic ids +-- make redelivery finish missing dispatches. data ProcessManagerAction ci targetCi = ProcessManagerAction { command :: !ci, commands :: ![PMCommand targetCi], diff --git a/src/Keiro/ProcessManager/Reaction.hs b/src/Keiro/ProcessManager/Reaction.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/ProcessManager/Reaction.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE CPP #-} + +-- | Additive process-manager reactions with explicit typed outcomes. +-- +-- A reaction may advance a private saga stream, run timer SQL atomically with +-- that append, and then dispatch commands to independent target streams. The +-- timer and target phases are deliberately separate transactions. Accepted +-- redelivery validates the recorded saga witness, skips timer SQL, and retries +-- target fan-out with deterministic target-keyed ids. +-- +-- 'NoAdvance' and silent domain decisions have no durable receipt. Their +-- unconditional timer effects may therefore run again, including around a +-- concurrent accepted delivery; effects that must be tied to acceptance belong +-- in @onAccepted@. Inputs to 'react', including command order and payloads, must +-- be stable for a source event. Dispatches are attempted in declared order, but +-- independent transactions, failures, and replay do not guarantee that commit +-- order. Switching an existing manager to this identity family requires a +-- drain; there is no positional-id fallback. +module Keiro.ProcessManager.Reaction + ( -- * Definition + ReactiveProcessManager (..), + ReactionPlan (..), + FollowUp (..), + ScheduleMode (..), + + -- * Results + ReactionStateResult (..), + ReactionTimerEffects (..), + ReactionError (..), + ReactiveProcessManagerResult (..), + + -- * Running + runReactiveProcessManagerOnce, + runReactiveProcessManagerWorkerWith, + runReactiveProcessManagerWorker, + + -- * Identity + deterministicReactionCommandId, + ) +where + +import Control.Monad (foldM) +#ifdef KEIRO_REACTION_HYDRATION_PROBE +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +#endif +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Coerce (coerce) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.UUID qualified as UUID +import Data.UUID.V5 qualified as UUID.V5 +import Data.Vector qualified as Vector +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, tryError) +import GHC.Stack (HasCallStack) +import Keiki.Core (BoolAlg, RegFile) +import Keiro.Codec (decodeRecorded) +import Keiro.Command + ( CommandError (..), + DomainCommandHandler, + DomainCommandOutcome (..), + DomainDecision (..), + RunCommandOptions, + runDomainCommandWithSqlEvents, + ) +import Keiro.DeadLetter (DispatcherKind (..)) +import Keiro.EventStream (EventStream) +import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated) +import Keiro.Prelude +import Keiro.ProcessManager + ( DispatchFailure (..), + PMCommand (..), + PMCommandResult (..), + PoisonPolicy (..), + WorkerOptions (..), + ackForCommandError, + decideForFailures, + defaultWorkerOptions, + deterministicCommandIdProbes, + dispatchDeduplicatedCommand, + firstExistingEventId, + ) +import Keiro.Projection (InlineProjection, runCommandWithProjections) +import Keiro.Stream (Stream) +import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison) +import Keiro.Timer + ( TimerId, + TimerRequest, + cancelTimerTx, + scheduleTimerOnceTx, + scheduleTimerTx, + ) +import Kiroku.Store.Effect (Store) +import Kiroku.Store.Effect.Resource (KirokuStoreResource) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Read (getStream, readStreamForward) +import Kiroku.Store.Transaction (runTransaction) +import Kiroku.Store.Types (EventId (..), RecordedEvent, StreamName (..), StreamVersion (..)) +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..)) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Attempt (..), Envelope (..)) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Streamly +#ifdef KEIRO_REACTION_HYDRATION_PROBE +import System.IO (stderr) +#endif +import "hasql-transaction" Hasql.Transaction qualified as Tx +import Prelude qualified + +-- | A pure reaction selected from one decoded input. +-- +-- 'NoAdvance' has no saga command and therefore cannot carry accepted-only +-- effects. 'AdvanceReaction' always runs @followUps@ for the observed outcome; +-- @onAccepted@ is added only when this invocation appends or recovers the +-- deterministic accepted witness. +data ReactionPlan ci targetCi + = NoAdvance ![FollowUp targetCi] + | AdvanceReaction + { command :: !ci, + followUps :: ![FollowUp targetCi], + onAccepted :: ![FollowUp targetCi] + } + deriving stock (Generic, Eq, Show) + +-- | One ordered reaction effect. Timer operations retain their relative order +-- in the timer transaction and dispatches retain theirs in the later target +-- phase; the two kinds are not one cross-stream transaction. 'Once' is +-- insert-only for the timer id, while 'Rearm' updates only a still-scheduled +-- row. Cancellation cannot revoke a callback that has already claimed a timer. +data FollowUp targetCi + = FollowDispatch !(PMCommand targetCi) + | FollowSchedule !ScheduleMode !TimerRequest + | FollowCancel !TimerId + deriving stock (Generic, Eq, Show) + +-- | Whether scheduling may move an existing still-scheduled row or is strictly +-- insert-only while any row with the timer id exists. +data ScheduleMode = Rearm | Once + deriving stock (Generic, Eq, Show) + +-- | The saga-state portion of a reaction result. +data ReactionStateResult target co rejection noOp + = ReactionNotAdvanced + | ReactionEvaluated !(DomainCommandOutcome target co rejection noOp) + | ReactionDuplicate !EventId + deriving stock (Generic, Eq, Show) + +-- | Honest accounting for the timer transaction that committed. +-- +-- @statementsCommitted@ includes no-op statements. @onceInserted@ and +-- @timersCancelled@ count only rows actually changed. Rearm intentionally has +-- no changed-row counter because the underlying SQL does not return one. +data ReactionTimerEffects = ReactionTimerEffects + { statementsCommitted :: !Int, + onceInserted :: !Int, + timersCancelled :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | Reaction failures that are not infrastructure failures. Store errors stay +-- in the ambient @Error StoreError@ effect. +data ReactionError + = ReactionCommandFailed !CommandError + | ReactionWitnessMissing !StreamName !EventId + | ReactionWitnessUndecodable !StreamName !EventId + deriving stock (Generic, Eq, Show) + +-- | Detailed result for a one-shot caller. Worker entry points use a strict +-- payload-free reduction instead of retaining this value through fan-out. +data ReactiveProcessManagerResult managerTarget co rejection noOp commandTarget = ReactiveProcessManagerResult + { managerResult :: !(ReactionStateResult managerTarget co rejection noOp), + commandResults :: ![PMCommandResult commandTarget], + timerEffects :: !ReactionTimerEffects + } + deriving stock (Generic, Eq, Show) + +-- | Runtime wiring for one reactive process manager. +data ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp = ReactiveProcessManager + { name :: !Text, + correlate :: !(input -> Text), + sagaHandler :: !(DomainCommandHandler phi rs s ci co rejection noOp), + streamFor :: !(Text -> Stream (EventStream phi rs s ci co)), + targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo), + targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]), + react :: !(input -> ReactionPlan ci targetCi) + } + deriving stock (Generic) + +zeroTimerEffects :: ReactionTimerEffects +zeroTimerEffects = ReactionTimerEffects 0 0 0 + +data EngineReducer managerTarget co rejection noOp commandTarget summary = EngineReducer + { beginReduction :: !(ReactionStateResult managerTarget co rejection noOp -> ReactionTimerEffects -> summary), + addDispatchReduction :: !(Int -> PMCommandResult commandTarget -> summary -> summary), + finishReduction :: !(summary -> summary) + } + deriving stock (Generic) + +data ReactionWorkerSummary = ReactionWorkerSummary + { workerDuplicates :: !Int64, + workerFailures :: ![DispatchFailure] + } + deriving stock (Generic, Eq, Show) + +-- | Run one reaction. Accepted saga events and their timer effects commit in +-- one transaction; target commands are then attempted independently in source +-- order. Duplicate accepted recovery validates the exact saga witness before +-- skipping timer SQL and retrying target dispatches. +runReactiveProcessManagerOnce :: + forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + RunCommandOptions -> + ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp -> + RecordedEvent -> + input -> + Eff + es + ( Either + ReactionError + ( ReactiveProcessManagerResult + (EventStream phi rs s ci co) + co + rejection + noOp + (EventStream targetPhi targetRs targetState targetCi targetCo) + ) + ) +runReactiveProcessManagerOnce options manager sourceEvent input = + runReactiveProcessManagerEngine onceReducer options manager sourceEvent input + where + onceReducer = + EngineReducer + { beginReduction = \managerResult timerEffects -> + ReactiveProcessManagerResult managerResult [] timerEffects, + addDispatchReduction = \_ commandResult result -> + result {commandResults = commandResult : result ^. #commandResults}, + finishReduction = \result -> + result {commandResults = Prelude.reverse (result ^. #commandResults)} + } + +runReactiveProcessManagerEngine :: + forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp summary es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + EngineReducer + (EventStream phi rs s ci co) + co + rejection + noOp + (EventStream targetPhi targetRs targetState targetCi targetCo) + summary -> + RunCommandOptions -> + ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp -> + RecordedEvent -> + input -> + Eff es (Either ReactionError summary) +runReactiveProcessManagerEngine reducer options manager sourceEvent input = + case (manager ^. #react) input of + NoAdvance unconditional -> do + timers <- runTimerPhase unconditional + finish ReactionNotAdvanced timers unconditional + AdvanceReaction sagaCommand unconditional acceptedOnly -> do + existing <- firstExistingEventId options sagaStreamName managerProbes + case existing of + Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly) + Nothing -> do + outcome <- + runDomainCommandWithSqlEvents + managerOptions + (manager ^. #sagaHandler) + sagaStream + sagaCommand + (\_ _ -> runTimerPhaseTx (unconditional <> acceptedOnly)) + case outcome of + Left commandError -> do + raced <- firstExistingEventId options sagaStreamName managerProbes + case raced of + Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly) + Nothing -> pure (Left (ReactionCommandFailed commandError)) + Right (domainOutcome@DomainCommandOutcome {decision = DomainAccepted {}}, Just timers) -> + finish (ReactionEvaluated domainOutcome) timers (unconditional <> acceptedOnly) + Right (DomainCommandOutcome {decision = DomainAccepted {}}, Nothing) -> + Prelude.error "runReactiveProcessManagerOnce: accepted append omitted timer callback result" + Right (domainOutcome, Nothing) -> do + raced <- firstExistingEventId options sagaStreamName managerProbes + case raced of + Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly) + Nothing -> do + timers <- runTimerPhase unconditional + finish (ReactionEvaluated domainOutcome) timers unconditional + Right (_, Just _) -> + Prelude.error "runReactiveProcessManagerOnce: silent decision returned a timer callback result" + where + correlationId = (manager ^. #correlate) input + sourceId = sourceEvent ^. #eventId + sagaStream = (manager ^. #streamFor) correlationId + sagaEventStream = (manager ^. #sagaHandler) ^. #eventStream + sagaStreamName = ((unvalidated sagaEventStream) ^. #resolveStreamName) sagaStream + managerProbes = deterministicCommandIdProbes (manager ^. #name) correlationId sourceId (-1) + managerId = NonEmpty.head managerProbes + managerOptions = options & #eventIds .~ [managerId] + + recoverAndFinish matchedId selected = do + recovered <- recoverWitness sagaEventStream sagaStreamName matchedId + case recovered of + Left err -> pure (Left err) + Right () -> finish (ReactionDuplicate matchedId) zeroTimerEffects selected + + finish state timers selected = do + let initial = (reducer ^. #beginReduction) state timers + initial `Prelude.seq` do + reduced <- + dispatchReactionCommandsWith + (reducer ^. #addDispatchReduction) + initial + options + manager + correlationId + sourceId + selected + pure (Right ((reducer ^. #finishReduction) reduced)) + +-- | Drain a Shibuya adapter with the configured poison, rejection, retry, and +-- telemetry policies. Each normally resolved delivery is finalized exactly +-- once. The worker reduces accepted saga payloads before target fan-out and +-- retains only duplicate and failure accounting while dispatching. +runReactiveProcessManagerWorkerWith :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + WorkerOptions es msg -> + RunCommandOptions -> + ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runReactiveProcessManagerWorkerWith workerOptions options manager Adapter {source = adapterSource} decodeMessage = + Streamly.fold Fold.drain + $ Streamly.mapM handleIngested adapterSource + where + handleIngested :: Ingested es msg -> Eff es AckDecision + handleIngested Ingested {envelope = env@Envelope {payload = message}, ack = AckHandle finalizeAck} = do + decision <- case decodeMessage message of + Nothing -> decidePoison env + Just (recorded, input) -> decideReaction env recorded input + finalizeAck decision + pure decision + + decideReaction env recorded input = do + let correlationId = (manager ^. #correlate) input + sagaStream = (manager ^. #streamFor) correlationId + sagaEventStream = (manager ^. #sagaHandler) ^. #eventStream + sagaStreamName = ((unvalidated sagaEventStream) ^. #resolveStreamName) sagaStream + attemptCount = envelopeAttemptCount env + outcome <- + tryError @StoreError + (runReactiveProcessManagerEngine workerReducer options manager recorded input) + case outcome of + Left (_, storeError) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeError)) + Right (Left (ReactionCommandFailed commandError)) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + decideForFailures + workerOptions + DispatcherProcessManager + (manager ^. #name) + correlationId + recorded + attemptCount + [DispatchFailure (-1) sagaStreamName commandError] + Right (Left witnessError) -> do + recordDispatchFailed (workerOptions ^. #metrics) 1 + pure (AckHalt (HaltFatal (witnessReason witnessError))) + Right (Right summary) -> do + recordDispatchDuplicate (workerOptions ^. #metrics) (summary ^. #workerDuplicates) + recordDispatchFailed + (workerOptions ^. #metrics) + (Prelude.fromIntegral (Prelude.length (summary ^. #workerFailures))) + decideForFailures + workerOptions + DispatcherProcessManager + (manager ^. #name) + correlationId + recorded + attemptCount + (summary ^. #workerFailures) + + decidePoison env = do + recordDispatchPoison (workerOptions ^. #metrics) 1 + case workerOptions ^. #poisonPolicy of + PoisonHalt -> pure (AckHalt (HaltFatal "process-reaction-worker-decode-failed")) + PoisonSkip callback -> do + callback env + pure AckOk + PoisonDeadLetter callback -> do + callback env + pure (AckDeadLetter (InvalidPayload "process-reaction-worker-decode-failed")) + + workerReducer = + EngineReducer + { beginReduction = \state _ -> + ReactionWorkerSummary + { workerDuplicates = case state of + ReactionDuplicate {} -> 1 + ReactionNotAdvanced -> 0 + ReactionEvaluated {} -> 0, + workerFailures = [] + }, + addDispatchReduction = \emitIndex result summary -> + case result of + PMCommandAppended {} -> summary + PMCommandDuplicate {} -> + summary {workerDuplicates = summary ^. #workerDuplicates Prelude.+ 1} + PMCommandFailed targetStreamName commandError -> + summary + { workerFailures = + DispatchFailure emitIndex targetStreamName commandError + : summary ^. #workerFailures + }, + finishReduction = \summary -> + summary {workerFailures = Prelude.reverse (summary ^. #workerFailures)} + } + + envelopeAttemptCount env = + case env ^. #attempt of + Nothing -> 1 + Just (Attempt attempt) -> Prelude.fromIntegral attempt Prelude.+ 1 + + witnessReason = \case + ReactionWitnessMissing {} -> "process-reaction-witness-missing" + ReactionWitnessUndecodable {} -> "process-reaction-witness-undecodable" + ReactionCommandFailed {} -> "process-reaction-command-failed" + +-- | Run a reactive process-manager worker with 'defaultWorkerOptions'. +runReactiveProcessManagerWorker :: + forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg phi (RegFile rs, ci), + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq co, + Eq targetCo + ) => + RunCommandOptions -> + ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp -> + Adapter es msg -> + (msg -> Maybe (RecordedEvent, input)) -> + Eff es () +runReactiveProcessManagerWorker = + runReactiveProcessManagerWorkerWith defaultWorkerOptions + +-- | Execute just the timer subsequence in one transaction. +runTimerPhase :: (IOE :> es, Store :> es) => [FollowUp targetCi] -> Eff es ReactionTimerEffects +runTimerPhase followUps + | List.null timerFollowUps = pure zeroTimerEffects + | otherwise = do + emitTimerPhaseProbe (List.length timerFollowUps) + runTransaction (runTimerPhaseTx followUps) + where + timerFollowUps = List.filter isTimerFollowUp followUps + isTimerFollowUp FollowSchedule {} = True + isTimerFollowUp FollowCancel {} = True + isTimerFollowUp FollowDispatch {} = False + +#ifdef KEIRO_REACTION_HYDRATION_PROBE +emitTimerPhaseProbe :: (IOE :> es) => Int -> Eff es () +emitTimerPhaseProbe statementCount = + liftIO + ( ByteString.Char8.hPutStrLn stderr + ( LazyByteString.toStrict + ( Aeson.encode + ( Aeson.object + [ "marker" Aeson..= ("reaction-probe" :: Text.Text), + "operation" Aeson..= ("timer-phase" :: Text.Text), + "statements" Aeson..= statementCount + ] + ) + ) + ) + ) +#else +emitTimerPhaseProbe :: Int -> Eff es () +emitTimerPhaseProbe _ = pure () +#endif + +runTimerPhaseTx :: [FollowUp targetCi] -> Tx.Transaction ReactionTimerEffects +runTimerPhaseTx = foldM step zeroTimerEffects + where + step summary = \case + FollowDispatch {} -> pure summary + FollowSchedule Rearm request -> do + scheduleTimerTx request + pure summary {statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1} + FollowSchedule Once request -> do + inserted <- scheduleTimerOnceTx request + pure + summary + { statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1, + onceInserted = summary ^. #onceInserted Prelude.+ if inserted then 1 else 0 + } + FollowCancel timerId -> do + cancelled <- cancelTimerTx timerId + pure + summary + { statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1, + timersCancelled = summary ^. #timersCancelled Prelude.+ if cancelled then 1 else 0 + } + +-- | Validate the exact accepted event while holding only one page at a time. +-- The stream version captured after the positive point probe is a finite read +-- ceiling, so a vanished witness cannot chase concurrent appends forever. +recoverWitness :: + (IOE :> es, Store :> es) => + ValidatedEventStream phi rs s ci co -> + StreamName -> + EventId -> + Eff es (Either ReactionError ()) +#ifdef KEIRO_REACTION_HYDRATION_PROBE +recoverWitness validated streamName witnessId = + do + let probeStreamName = case streamName of StreamName name -> name + liftIO + ( ByteString.Char8.hPutStrLn stderr + ( LazyByteString.toStrict + ( Aeson.encode + ( Aeson.object + [ "marker" Aeson..= ("reaction-probe" :: Text.Text), + "operation" Aeson..= ("witness" :: Text.Text), + "stream" Aeson..= probeStreamName + ] + ) + ) + ) + ) + recoverWitnessAfterProbe validated streamName witnessId +#else +recoverWitness validated streamName witnessId = + recoverWitnessAfterProbe validated streamName witnessId +#endif + +recoverWitnessAfterProbe :: + (Store :> es) => + ValidatedEventStream phi rs s ci co -> + StreamName -> + EventId -> + Eff es (Either ReactionError ()) +recoverWitnessAfterProbe validated streamName witnessId = do + streamInfo <- getStream streamName + case streamInfo of + Nothing -> pure (Left missing) + Just info -> scan (info ^. #id) (info ^. #version) (StreamVersion 0) + where + missing = ReactionWitnessMissing streamName witnessId + codec = (unvalidated validated) ^. #eventCodec + pageSize = 256 + + scan expectedStreamId ceiling cursor = do + page <- readStreamForward streamName cursor pageSize + let withinCeiling = Vector.takeWhile (\event -> event ^. #streamVersion <= ceiling) page + found = Vector.find (\event -> event ^. #eventId == witnessId) withinCeiling + case found of + Just witness + | witness ^. #originalStreamId /= expectedStreamId -> pure (Left missing) + | otherwise -> + pure + $ case decodeRecorded codec witness of + Left _ -> Left (ReactionWitnessUndecodable streamName witnessId) + Right _ -> Right () + Nothing + | Vector.null withinCeiling -> pure (Left missing) + | otherwise -> + let next = (Vector.last withinCeiling) ^. #streamVersion + in if next >= ceiling + then pure (Left missing) + else scan expectedStreamId ceiling next + +dispatchReactionCommandsWith :: + forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp summary es. + ( HasCallStack, + IOE :> es, + Store :> es, + Error StoreError :> es, + KirokuStoreResource :> es, + BoolAlg targetPhi (RegFile targetRs, targetCi), + Eq targetCo + ) => + (Int -> PMCommandResult (EventStream targetPhi targetRs targetState targetCi targetCo) -> summary -> summary) -> + summary -> + RunCommandOptions -> + ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp -> + Text -> + EventId -> + [FollowUp targetCi] -> + Eff es summary +dispatchReactionCommandsWith reduce initial options manager correlationId sourceId = + go Map.empty 0 initial + where + go _ _ summary [] = pure summary + go occurrences dispatchIndex summary (followUp : rest) = + case followUp of + FollowDispatch dispatched -> do + let targetStream = retarget (dispatched ^. #target) + targetName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream + occurrence = Map.findWithDefault 0 targetName occurrences + nextOccurrences = Map.insert targetName (occurrence Prelude.+ 1) occurrences + commandId = + deterministicReactionCommandId + (manager ^. #name) + correlationId + sourceId + targetName + occurrence + result <- dispatchOne targetStream targetName commandId dispatched + let nextSummary = reduce dispatchIndex result summary + nextSummary `Prelude.seq` go nextOccurrences (dispatchIndex Prelude.+ 1) nextSummary rest + _ -> go occurrences dispatchIndex summary rest + + dispatchOne targetStream targetName commandId dispatched = do + let targetOptions = options & #eventIds .~ [commandId] + dispatchedInitial <- + dispatchDeduplicatedCommand + options + targetName + (commandId :| []) + PMCommandDuplicate + (PMCommandFailed targetName) + PMCommandAppended + ( runCommandWithProjections + targetOptions + (manager ^. #targetEventStream) + targetStream + (dispatched ^. #command) + ((manager ^. #targetProjections) (dispatched ^. #target)) + ) + case dispatchedInitial of + PMCommandFailed {} -> reconcile dispatchedInitial + PMCommandAppended commandResult + | commandResult ^. #eventsAppended == 0 -> reconcile dispatchedInitial + _ -> pure dispatchedInitial + where + reconcile preserved = do + raced <- firstExistingEventId options targetName (commandId :| []) + pure (maybe preserved PMCommandDuplicate raced) + + retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo) + retarget = coerce + +-- | Derive the stable first-event id for one reaction target command. +-- +-- Every field is encoded as its decimal UTF-8 byte length, a colon, and the +-- bytes. The fields are, in order: @keiro@, @process-reaction@, manager name, +-- correlation id, canonical source UUID text, physical target stream name, and +-- decimal zero-based occurrence among commands to that target. +deterministicReactionCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId +deterministicReactionCommandId managerName correlationId sourceEventId targetStreamName occurrence = + EventId + $ UUID.V5.generateNamed UUID.V5.namespaceURL + $ ByteString.unpack + $ ByteString.concat + $ fmap + encodeField + [ "keiro", + "process-reaction", + managerName, + correlationId, + UUID.toText (coerce sourceEventId), + coerce targetStreamName, + Text.pack (show occurrence) + ] + where + encodeField field = + let bytes = Text.Encoding.encodeUtf8 field + in ByteString.concat + [ ByteString.Char8.pack (show (ByteString.length bytes)), + ByteString.singleton 58, + bytes + ] diff --git a/src/Keiro/ReadModel.hs b/src/Keiro/ReadModel.hs --- a/src/Keiro/ReadModel.hs +++ b/src/Keiro/ReadModel.hs @@ -18,7 +18,7 @@ -- deprecated 'runQueryWith' waiting overrides. Define new models through -- 'ReadModelBlueprint' and the truthful builders. 'ConsistencyMode', direct -- waiting fields, and 'runQueryWith' remain deprecated 0.12 compatibility and --- are removed in 0.13. +-- remain until the frozen Language 4 read-model generator is retired. -- -- Schema lifecycle (registration, status transitions) lives in -- "Keiro.ReadModel.Schema", which is re-exported here. @@ -331,27 +331,29 @@ pollMicros = 10000 } -{-# DEPRECATED ConsistencyMode "Use QueryFreshness. ConsistencyMode remains through the 0.12 compatibility window and is removed in 0.13." #-} +-- Published keiro-dsl Language 4 output still names this compatibility surface. +-- Keep it until that frozen read-model generator is retired. +{-# DEPRECATED ConsistencyMode "Use QueryFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED Strong "Use WaitForHead. Strong is a bounded captured-head wait, not linearizability; it is removed in 0.13." #-} +{-# DEPRECATED Strong "Use WaitForHead. Strong is a bounded captured-head wait, not linearizability. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED Eventual "Use Immediate. Eventual means only that the query does not wait; it is removed in 0.13." #-} +{-# DEPRECATED Eventual "Use Immediate. Eventual means only that the query does not wait. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED PositionWait "Use WaitForPosition with a concrete target. Legacy PositionWait Nothing remains immediate through 0.12 and is removed in 0.13." #-} +{-# DEPRECATED PositionWait "Use WaitForPosition with a concrete target. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED StrongScope "Use HeadScope. StrongScope remains through the 0.12 compatibility window and is removed in 0.13." #-} +{-# DEPRECATED StrongScope "Use HeadScope. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED EntireLog "Use EntireVisibleLog. EntireLog remains through the 0.12 compatibility window and is removed in 0.13." #-} +{-# DEPRECATED EntireLog "Use EntireVisibleLog. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED CategoryHead "Use CategoryVisibleHead. CategoryHead remains through the 0.12 compatibility window and is removed in 0.13." #-} +{-# DEPRECATED CategoryHead "Use CategoryVisibleHead. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED defaultStrongWaitOptions "Use defaultHeadWaitOptions. The legacy name is removed in 0.13." #-} +{-# DEPRECATED defaultStrongWaitOptions "Use defaultHeadWaitOptions. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED subscriptionName "Use ReadModelBlueprint.cursorAuthority and readModelCursorAuthority. The legacy record field is removed in 0.13." #-} +{-# DEPRECATED subscriptionName "Use ReadModelBlueprint.cursorAuthority and readModelCursorAuthority. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED defaultConsistency "Use ReadModelBlueprint builders and readModelDefaultFreshness. The legacy record field is removed in 0.13." #-} +{-# DEPRECATED defaultConsistency "Use ReadModelBlueprint builders and readModelDefaultFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED strongScope "Use HeadScope through the ReadModelBlueprint builders. The legacy record field is removed in 0.13." #-} +{-# DEPRECATED strongScope "Use HeadScope through the ReadModelBlueprint builders. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -- | Why a read-model query could not run. data ReadModelError @@ -415,7 +417,7 @@ Eff es (Either ReadModelError r) runQueryWith metrics consistency readModel = runQueryWithFreshness metrics (legacyOverrideFreshness consistency readModel) readModel -{-# DEPRECATED runQueryWith "Use runQueryWithFreshness. The legacy override is removed in 0.13." #-} +{-# DEPRECATED runQueryWith "Use runQueryWithFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits the legacy consistency surface and is removed with that generator in a later major release." #-} runValidatedQuery :: (Store :> es) => diff --git a/src/Keiro/Telemetry.hs b/src/Keiro/Telemetry.hs --- a/src/Keiro/Telemetry.hs +++ b/src/Keiro/Telemetry.hs @@ -73,6 +73,7 @@ keiroOutboxBacklogName, keiroOutboxPublishedName, keiroOutboxRejectedName, + keiroOutboxIdentityConflictName, keiroOutboxRetriedName, keiroOutboxDeadletteredName, keiroOutboxReclaimedName, @@ -126,6 +127,7 @@ recordOutboxBacklog, recordOutboxPublished, recordOutboxRejected, + recordOutboxIdentityConflict, recordOutboxRetried, recordOutboxDeadlettered, recordOutboxReclaimed, @@ -581,6 +583,9 @@ keiroOutboxPublishedName :: Text keiroOutboxPublishedName = "keiro.outbox.published" +keiroOutboxIdentityConflictName :: Text +keiroOutboxIdentityConflictName = "keiro.outbox.identity.conflict" + keiroOutboxRejectedName :: Text keiroOutboxRejectedName = "keiro.outbox.rejected" @@ -742,6 +747,7 @@ { outboxBacklog :: Gauge Int64, outboxPublished :: Counter Int64, outboxRejected :: Counter Int64, + outboxIdentityConflict :: Counter Int64, outboxRetried :: Counter Int64, outboxDeadlettered :: Counter Int64, outboxReclaimed :: Counter Int64, @@ -802,6 +808,7 @@ newKeiroMetrics meter = liftIO $ do outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish." outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published." + outboxIdentityConflict' <- counterI64 keiroOutboxIdentityConflictName "{event}" "Producer enqueues refused because retained identity has different content." outboxRejected' <- counterI64 keiroOutboxRejectedName "{event}" "Outbox events intentionally and permanently rejected by the publisher." outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry." outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries." @@ -856,6 +863,7 @@ { outboxBacklog = outboxBacklog', outboxPublished = outboxPublished', outboxRejected = outboxRejected', + outboxIdentityConflict = outboxIdentityConflict', outboxRetried = outboxRetried', outboxDeadlettered = outboxDeadlettered', outboxReclaimed = outboxReclaimed', @@ -939,6 +947,10 @@ recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxPublished = recordCounter outboxPublished + +-- | Record after the transaction runner returns, including deliberate checkpoint rollback. +recordOutboxIdentityConflict :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () +recordOutboxIdentityConflict = recordCounter outboxIdentityConflict recordOutboxRejected :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxRejected = recordCounter outboxRejected diff --git a/src/Keiro/Timer.hs b/src/Keiro/Timer.hs --- a/src/Keiro/Timer.hs +++ b/src/Keiro/Timer.hs @@ -66,6 +66,7 @@ findStuckTimers, requeueStuckTimers, requeueStuckTimer, + cancelTimerTx, cancelTimer, deadLetterTimer, 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 @@ -59,6 +59,7 @@ findStuckTimers, requeueStuckTimers, requeueStuckTimer, + cancelTimerTx, cancelTimer, deadLetterTimer, ) @@ -518,9 +519,15 @@ -- state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left -- untouched. Idempotent. Returns 'True' when a row changed. cancelTimer :: (Store :> es) => TimerId -> Eff es Bool -cancelTimer timerId = - runTransaction $ - Tx.statement (timerIdToUuid timerId) cancelTimerStmt +cancelTimer = runTransaction . cancelTimerTx + +-- | Transactional form of 'cancelTimer'. It uses the same guarded SQL but lets +-- callers compose cancellation atomically with an event append and other timer +-- mutations. Foreground-owned rows remain protected even after their lease has +-- expired; recovery must clear their ownership token first. +cancelTimerTx :: TimerId -> Tx.Transaction Bool +cancelTimerTx timerId = + Tx.statement (timerIdToUuid timerId) cancelTimerStmt -- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state, -- recording @reason@ in @last_error@ so an operator can see why it was abandoned diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,15260 +10,17051 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar) import Control.Concurrent.STM (atomically, putTMVar) -import Control.Exception (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try) -import Control.Monad (forM, forM_) -import Data.Aeson (object, withObject, (.:), (.:?)) -import Data.Aeson qualified as Aeson -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types (parseEither) -import Data.ByteString (ByteString) -import Data.Char (isDigit) -import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) -import Data.Int (Int32) -import Data.List (isInfixOf) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes) -import Data.Monoid (mempty) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Text.Encoding qualified as TE -import Data.Text.IO qualified as TextIO -import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime) -import Data.Time.Calendar (Day (ModifiedJulianDay)) -import Data.UUID (UUID, fromString, fromWords64) -import Data.UUID qualified as UUID -import Data.UUID.V5 qualified as UUID.V5 -import Data.Vector qualified as Vector -import Data.Version (showVersion) -import Data.Word (Word64) -import Effectful (Eff, IOE, (:>)) -import Effectful.Error.Static (Error, throwError) -import Effectful.Exception qualified as EffException -import ExternalReadSpec qualified -import GHC.Conc (ThreadStatus (..), threadStatus) -import GroupRebuildSpec qualified -import Hasql.Decoders qualified as D -import Hasql.Encoders qualified as E -import Hasql.Statement (Statement, preparable) -import Keiki.Core - ( Edge (..), - HsPred (..), - InCtor (..), - IndexN, - RegFile (..), - SymTransducer (..), - Update (..), - WireCtor (..), - inpCtor, - lit, - matchInCtor, - oNil, - pack, - proj, - (*:), - (.==), - ) -import Keiki.Core qualified as Keiki -import Keiki.Generics (emptyRegFile) -import Keiki.Operators qualified as K -import Keiki.Shape (CanonicalStateShape) -import Keiro -import Keiro qualified as KeiroRoot -import Keiro.Codec.Nominal - ( NominalBinding (..), - NominalFixture (..), - NominalFixtureCases (..), - nominalDomainRoundTrip, - nominalRepresentationRoundTrip, - ) -import Keiro.Codec.Structural - ( StructuralBinding (..), - bindingDomainRoundTrip, - bindingShapeRoundTrip, - decodeViaBinding, - encodeViaBinding, - ) -import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema) -import Keiro.DeadLetter - ( DispatchDeadLetter (..), - DispatcherKind (..), - listDispatchDeadLetters, - recordDispatchDeadLetter, - ) -import Keiro.DeadLetter.Replay - ( ReplayOutcome (..), - ReplayResult (..), - listSubscriptionDeadLetters, - replaySubscriptionDeadLetters, - ) -import Keiro.DeterministicId (deterministicIdProbes, identitySeedBytes, legacySeedBytes) -import Keiro.EventStream (Terminality (..)) -import Keiro.EventStream.Validate - ( EventStreamWarning (..), - ValidatedEventStream, - mkEventStream, - mkEventStreamOrThrow, - mkEventStreamUnchecked, - mkEventStreamWith, - validateEventStream, - ) -import Keiro.Inbox - ( InboxDedupePolicy (..), - InboxError (..), - InboxPersistence (..), - InboxResult (..), - InboxStatus (..), - KafkaDeliveryRef (..), - garbageCollectCompleted, - listInbox, - lookupInbox, - markFailedTx, - runInboxTransaction, - runInboxTransactionBatch, - runInboxTransactionWith, - runInboxTransactionWithRetries, - runInboxTransactionWithRetriesWith, - sampleInboxBacklog, - ) -import Keiro.Inbox.Kafka qualified as InboxKafka -import Keiro.Integration.Event - ( IntegrationContentType (..), - IntegrationEvent (..), - SchemaReference (..), - TraceContext (..), - decodeJsonIntegrationEvent, - encodeJsonIntegrationEvent, - headerContentType, - headerMessageId, - headerSchemaSubject, - headerSchemaVersion, - headerSourceEventId, - headerSourceGlobalPosition, - headerTraceParent, - integrationHeaders, - integrationPayload, - parseContentType, - ) -import Keiro.Integration.Event qualified as IntegrationEvent -import Keiro.Outbox - ( BackoffSchedule (..), - ExponentialBackoffOptions (..), - IntegrationEventDraft (..), - IntegrationProducer (..), - IntegrationProducerConfigError (..), - OrderingPolicy (..), - OutboxId (..), - OutboxPublishConfigError (..), - OutboxRow (..), - OutboxStatus (..), - PublishOutcome (..), - PublishRejectionError (..), - claimOutboxBatch, - defaultMaintenanceOptions, - defaultPublishOptions, - draftToEvent, - enqueueIntegrationEventTx, - freshOutboxId, - garbageCollectSent, - lookupOutbox, - markOutboxSent, - mintIntegrationEvent, - mkIntegrationProducer, - mkOutboxPublishOptions, - mkPublishRejection, - outboxMaintenancePass, - publishClaimedOutbox, - publishRejectionCode, - publishRejectionDetail, - sampleOutboxBacklog, - ) -import Keiro.Outbox.Kafka qualified as OutboxKafka -import Keiro.Outbox.Schema (markOutboxFailedTx, markOutboxRejectedTx) -import Keiro.Prelude -import Keiro.ProcessManager -import Keiro.Projection -import Keiro.ReadModel -import Keiro.ReadModel.Rebuild qualified as Rebuild -import Keiro.ReplayAudit qualified as ReplayAudit -import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan) -import Keiro.Stream qualified as Stream -import Keiro.Subscription.Shard - ( ShardCountMismatch (..), - ShardLease (..), - WorkerId (..), - ensureShards, - fairShareTarget, - ) -import Keiro.Subscription.Shard.Schema - ( claimShardsTx, - ensureShardRows, - listShardOwnership, - releaseShardsTx, - renewLeaseTx, - ) -import Keiro.Subscription.Shard.Worker - ( ShardAck (..), - ShardWorkerError (..), - ShardedWorkerConfigError (..), - ShardedWorkerOptions (..), - acquireOutcome, - defaultShardedWorkerOptions, - mkShardedWorkerOptions, - reconcileShardsOnce, - runShardedSubscriptionGroup, - runShardedSubscriptionGroupAck, - ) -import Keiro.Telemetry qualified as Telemetry -import Keiro.Test.Postgres - ( StoreRunner (..), - withFreshDatabase, - withFreshResourceStore, - withFreshResourceStoreWith, - withFreshStore, - withFreshStoreWith, - withFreshStores2, - withMigratedSuite, - ) -import Keiro.Timer -import Keiro.Timer qualified as Timer -import Keiro.Wake - ( WakeReason (..), - WakeSignal (..), - neverWake, - wakeSignalFromStore, - ) -import Keiro.Workflow - ( LeaseHeartbeat (..), - PatchId (..), - StepName (..), - Workflow, - WorkflowError (..), - WorkflowId (..), - WorkflowIdentityError (..), - WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed), - WorkflowLeaseLost (..), - WorkflowName (..), - WorkflowOutcome (..), - appendJournalEntry, - appendJournalEntryReturningId, - awaitStep, - awakeableAllocStepPrefix, - awakeableStepPrefix, - cancelledStepName, - completedStepName, - continueAsNew, - continueSeedStepName, - continuedAsNewStepName, - currentGeneration, - defaultWorkflowRunOptions, - deterministicJournalId, - failedStepName, - findUnfinishedWorkflowIds, - loadStepIndex, - mkWorkflowId, - mkWorkflowName, - patch, - patchSetStepName, - patchStepName, - restoreSeed, - runWorkflow, - runWorkflowWith, - step, - stepExists, - workflowGenerationStreamName, - workflowJournalCodec, - ) -import Keiro.Workflow.Awakeable - ( AwakeableId (..), - WorkflowAwakeableCancelled (..), - awakeableIdText, - awakeableIdToUuid, - awakeableNamed, - cancelAwakeable, - signalAwakeable, - signalAwakeableFrom, - ) -import Keiro.Workflow.Awakeable.Compatibility - ( generation0AwakeableId, - preUtf8Generation0AwakeableId, - ) -import Keiro.Workflow.Awakeable.Schema qualified as Awk -import Keiro.Workflow.Child - ( ChildHandle (..), - WorkflowChildCancelled (..), - WorkflowChildFailed (..), - awaitChild, - cancelChild, - childCompletionHook, - childResultStepName, - childSpawnStepName, - runChildWorkflow, - spawnChild, - ) -import Keiro.Workflow.Child.Schema qualified as Child -import Keiro.Workflow.Gc qualified as WorkflowGc -import Keiro.Workflow.Instance qualified as Instance -import Keiro.Workflow.Resume - ( ResumeLogEvent (..), - ResumeSummary (..), - WorkflowDef (..), - defaultWorkflowResumeOptions, - emptyResumeSummary, - resumeWorkflowsOnce, - runPollLoopWith, - runWorkflowResumeWorkerPush, - runWorkflowResumeWorkerWith, - ) -import Keiro.Workflow.Sleep - ( drainWorkflowSleepTimers, - matchSleepTimerGeneration, - parseSleepPayload, - runWorkflowTimerWorker, - sleepNamed, - sleepStepName, - sleepTimerId, - sleepTimerPayload, - workflowSleepFireAction, - ) -import Keiro.Workflow.Snapshot - ( loadWorkflowSnapshot, - workflowStateCodec, - ) -import Kiroku.Store qualified as Store -import Kiroku.Store.Effect (Store) -import Kiroku.Store.SQL qualified as KirokuSQL -import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) -import Kiroku.Store.Subscription.Types - ( SubscriptionName (..), - SubscriptionTarget (..), - ) -import Kiroku.Store.Subscription.Types qualified as KirokuSub -import Kiroku.Store.Types - ( CategoryName (..), - EventData (..), - EventId (..), - EventType (..), - ExpectedVersion (..), - GlobalPosition (..), - RecordedEvent (..), - StreamId (..), - StreamName (..), - StreamVersion (..), - ) -import Numeric.Natural (Natural) -import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute) -import OpenTelemetry.Attributes.Key (AttributeKey, unkey) -import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter) -import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) -import OpenTelemetry.Exporter.Metric - ( GaugeDataPoint (..), - HistogramDataPoint (..), - MetricExport (..), - NumberValue (..), - ResourceMetricsExport (..), - ScopeMetricsExport (..), - SumDataPoint (..), - ) -import OpenTelemetry.MeterProvider - ( SdkMeterProviderOptions (..), - createMeterProvider, - defaultSdkMeterProviderOptions, - ) -import OpenTelemetry.Metric.Core - ( forceFlushMeterProvider, - getMeter, - ) -import OpenTelemetry.Resource (emptyMaterializedResources) -import OpenTelemetry.Trace - ( SpanStatus (..), - createTracerProvider, - emptyTracerProviderOptions, - makeTracer, - shutdownTracerProvider, - tracerOptions, - ) -import OpenTelemetry.Trace.Core - ( ImmutableSpan (..), - Span, - SpanContext (..), - SpanHot (..), - SpanKind, - getSpanContext, - ) -import Paths_keiro qualified as Package -import PreCanonicalRecoverySpec qualified -import PreimageSpec qualified -import ProjectionReplaySpec qualified -import ReadModelSpec qualified -import Shibuya.Adapter (Adapter (..)) -import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..), deadLetterCodeText, deadLetterReasonCode, deadLetterReasonDetail, renderDeadLetterReason) -import Shibuya.Core.AckHandle (AckHandle (..)) -import Shibuya.Core.Ingested (Ingested (..)) -import Shibuya.Core.Types (Envelope (..)) -import Streamly.Data.Stream qualified as Streamly -import System.Exit (ExitCode (..)) -import System.Process (readProcessWithExitCode) -import System.Timeout (timeout) -import Test.Hspec -import VersionedRebuildSpec qualified -import VersionedTargetPostgresSpec qualified -import "hasql-transaction" Hasql.Transaction qualified as Tx - -main :: IO () -main = withMigratedSuite $ \fixture -> hspec $ do - CatalogSpec.spec - PreimageSpec.spec - CatalogEvolutionSpec.spec fixture - CatalogOperationsSpec.spec fixture - GroupRebuildSpec.spec fixture - ExternalReadSpec.spec fixture - VersionedTargetPostgresSpec.spec fixture - VersionedRebuildSpec.spec fixture - PreCanonicalRecoverySpec.spec fixture - ProjectionReplaySpec.spec fixture - ReadModelSpec.spec - - describe "catalog-fenced inline projections" $ around (withFreshResourceStore fixture) $ do - it "rolls back the event append and target write while its group rebuilds" $ \(_storeHandle, StoreRunner runStore) -> do - validated <- - case validateProjectionCatalog catalogInlineProjectionCatalog of - Failure diagnostics -> - expectationFailure ("catalog fixture failed validation: " <> show diagnostics) - >> error "unreachable" - Success value -> pure value - Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) - Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated - - let targetStream = stream "counter-catalog-fence" :: Stream CounterEventStream - first <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 4) - validated - catalogInlineProjectionSet - first `shouldSatisfy` \case - Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 - _ -> False - Right 1 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - - Right (Right _) <- - runStore $ - Rebuild.beginGroupRebuild - validated - catalogInlineGroupId - Rebuild.RebuildRequest - { rebuildRunId = catalogInlineRunId, - requestedBy = "keiro-test", - requestReason = "inline fence proof", - replayFrom = GlobalPosition 0 - } - Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - - second <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 5) - validated - catalogInlineProjectionSet - second - `shouldBe` Right (Right (ProjectionCommandFenced catalogInlineGroupId catalogInlineRunId)) - Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - Right recorded <- - runStore $ - Store.readStreamForward (StreamName "counter-catalog-fence") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - let foreignSource = catalogIdentity mkSourceId "catalog-inline-foreign-source" - foreignSet = catalogInlineProjectionSet & #projectionSource .~ foreignSource - foreignStream = stream "counter-catalog-mismatch" :: Stream CounterEventStream - mismatch <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - foreignStream - (Add 6) - validated - foreignSet - mismatch `shouldBe` Right (Right (ProjectionCommandCatalogMismatch foreignSource)) - Right absent <- - runStore $ - Store.readStreamForward (StreamName "counter-catalog-mismatch") (StreamVersion 0) 10 - Vector.null absent `shouldBe` True - - it "waits for an in-flight writer before preparing and clearing its group" $ \(_storeHandle, StoreRunner runStore) -> do - validated <- - case validateProjectionCatalog catalogInlineProjectionCatalog of - Failure diagnostics -> - expectationFailure ("catalog fixture failed validation: " <> show diagnostics) - >> error "unreachable" - Success value -> pure value - Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) - Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated - - writerDone <- newEmptyMVar - let targetStream = stream "counter-catalog-lock-order" :: Stream CounterEventStream - _ <- - forkIO $ - runStore - ( runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 9) - validated - catalogSlowInlineProjectionSet - ) - >>= putMVar writerDone - threadDelay 200_000 - startedAt <- getCurrentTime - Right (Right _) <- - runStore $ - Rebuild.beginGroupRebuild - validated - catalogInlineGroupId - Rebuild.RebuildRequest - { rebuildRunId = catalogInlineRunId, - requestedBy = "keiro-test", - requestReason = "in-flight inline lock proof", - replayFrom = GlobalPosition 0 - } - finishedAt <- getCurrentTime - - writer <- takeMVar writerDone - writer `shouldSatisfy` \case - Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 - _ -> False - diffUTCTime finishedAt startedAt `shouldSatisfy` (> 0.5) - Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - pure () - - it "dispatches inline writes through the persisted serving revision before appending" $ \(_storeHandle, StoreRunner runStore) -> do - validated <- expectValidatedCatalog catalogInlineProjectionCatalog - v1Only <- expectValidatedCatalog catalogInlineV1Catalog - Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) - Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated - Right () <- runStore $ Store.runTransaction (Tx.sql seedCatalogInlineVersionedV1Sql) - - let targetStream = stream "counter-versioned-inline" :: Stream CounterEventStream - first <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 4) - validated - catalogInlineProjectionSet - first `shouldSatisfy` \case - Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 - _ -> False - Right [101] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) - - Right () <- runStore $ Store.runTransaction (Tx.sql promoteCatalogInlineV2Sql) - second <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 5) - validated - catalogInlineProjectionSet - second `shouldSatisfy` \case - Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 - _ -> False - Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) - - missing <- - runStore $ - runCommandWithCatalogProjections - defaultRunCommandOptions - counterEventStream - targetStream - (Add 6) - v1Only - catalogInlineProjectionSet - missing - `shouldBe` Right - ( Right - ( ProjectionCommandServingRevisionUnavailable - catalogInlineGroupId - catalogInlineRevisionV2Id - ) - ) - Right recorded <- - runStore $ - Store.readStreamForward (StreamName "counter-versioned-inline") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 2 - Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) - pure () - - describe "Keiro" $ do - it "exposes the package metadata version" $ - KeiroRoot.version `shouldBe` Text.pack (showVersion Package.version) - - it "keeps package metadata as the only version authority" $ do - source <- TextIO.readFile "src/Keiro.hs" - source `shouldSatisfy` Text.isInfixOf "showVersion Package.version" - let isNumericVersionAssignment sourceLine = - "version =" `Text.isInfixOf` sourceLine - && Text.count "." sourceLine >= 3 - && Text.any isDigit sourceLine - Text.lines source `shouldSatisfy` all (not . isNumericVersionAssignment) - - describe "Keiro.Telemetry metrics" $ do - it "records instrument names and values through an SDK meter" $ do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - let h = Just metrics - -- A counter (monotonic sum), a gauge (last value wins), a histogram. - Telemetry.recordOutboxPublished h 3 - Telemetry.recordOutboxPublished h 2 - Telemetry.recordOutboxBacklog h 7 - Telemetry.recordInboxDuplicates h 1 - Telemetry.recordTimerFireLag h 12.5 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - -- The counter accumulated 3 + 2 = 5. - lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5) - -- The gauge holds its last recorded value. - lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7) - -- The duplicate counter holds 1. - lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) - -- The histogram saw one observation summing to 12.5. - let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] - lag `shouldBe` [(1, 12.5)] - -- Instruments we never recorded export no points. - lookup "keiro.timer.stuck" scalars `shouldBe` Nothing - - it "records nothing through a Nothing handle" $ do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - -- A Nothing handle is the no-op path: helpers must short-circuit. - let h = Nothing - Telemetry.recordOutboxPublished h 99 - Telemetry.recordOutboxBacklog h 99 - Telemetry.recordTimerFireLag h 99.0 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - flattenScalarPoints exported `shouldBe` [] - flattenHistogramPoints exported `shouldBe` [] - - describe "Kiroku retry exhaustion observability" $ do - it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - forwarded <- newIORef (0 :: Int) - let observe _ = modifyIORef' forwarded (+ 1) - installBridge settings = - settings - & #eventHandler - .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe) - withFreshStoreWith fixture installBridge $ \store -> do - total <- seedOrders store 1 2 - total `shouldBe` 2 - let subName = SubscriptionName "orders-retry-exhaustion" - subConfig = - ( KirokuSub.defaultSubscriptionConfig - subName - (Category (CategoryName "orders")) - (\_ -> pure KirokuSub.Continue) - ) - { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2 - } - pull label source = do - result <- timeout 5_000_000 (Streamly.uncons source) - case result of - Just (Just itemAndRest) -> pure itemAndRest - Just Nothing -> fail (label <> ": subscription ended early") - Nothing -> fail (label <> ": timed out waiting for delivery") - number item = - parseEither - (withObject "OrderPlaced" (.: "n")) - (ackEvent item ^. #payload) - (stream0, cancelStream) <- subscriptionAckStream store subConfig 4 - ( do - (first, stream1) <- pull "initial poison delivery" stream0 - ackAttempt first `shouldBe` 0 - number first `shouldBe` Right (0 :: Int) - atomically $ - putTMVar - (ackReply first) - (KirokuSub.Retry (KirokuSub.RetryDelay 0)) - - (retry, stream2) <- pull "poison redelivery" stream1 - ackAttempt retry `shouldBe` 1 - ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId - atomically $ - putTMVar - (ackReply retry) - (KirokuSub.Retry (KirokuSub.RetryDelay 0)) - - (next, stream3) <- pull "event after exhausted poison" stream2 - ackAttempt next `shouldBe` 0 - number next `shouldBe` Right (1 :: Int) - ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId - atomically (putTMVar (ackReply next) KirokuSub.Stop) - ended <- timeout 5_000_000 (Streamly.uncons stream3) - case ended of - Just Nothing -> pure () - Just (Just _) -> expectationFailure "subscription delivered after Stop" - Nothing -> expectationFailure "subscription did not stop after the final acknowledgement" - ) - `finally` cancelStream - - Right rows <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.statement - ("orders-retry-exhaustion", 0) - KirokuSQL.readDeadLettersStmt - case Vector.toList rows of - [row] -> do - row ^. #deadLetterReason - `shouldBe` object - [ "kind" Aeson..= ("max_attempts_exceeded" :: Text), - "attempts" Aeson..= (2 :: Int) - ] - row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)" - row ^. #deadLetterAttemptCount `shouldBe` 2 - other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other) - - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - readIORef forwarded >>= (`shouldSatisfy` (> 1)) - - describe "Keiro.Stream" $ do - it "wraps and unwraps kiroku stream names" $ do - let orderStream = stream "order-123" :: Stream OrderStream - Stream.streamName orderStream `shouldBe` StreamName "order-123" - Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream) - `shouldBe` StreamName "order-123-archived" - - it "validates categories, rejecting the dash boundary and reserved names" $ do - fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "incident" - -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted - fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "hospitalSurge" - fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Right "wf:fulfillment" - (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left Stream.CategoryEmpty - (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge") - (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryReserved "$all") - (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers") - (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ())) - `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners") - - it "builds entity streams that round-trip through kiroku's category rule" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1" - Stream.categoryName cat `shouldBe` CategoryName "orders" - -- The category keiro reports equals kiroku's own parse of the produced - -- name, even when the id segment itself contains a dash. - Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c")) - `shouldBe` Stream.categoryName cat - - it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1" - Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1" - - it "rejects blank entity stream id segments" $ do - let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream - evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall - evaluate (Stream.streamName (Stream.entityStream cat " ")) `shouldThrow` anyErrorCall - - describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do - it "records a dispatch dead letter idempotently" $ \storeHandle -> do - let deadLetter = - DispatchDeadLetter - { dispatcherKind = DispatcherProcessManager, - dispatcherName = "orders-pm", - correlationId = "order-42", - sourceEventId = EventId sampleUuid, - sourceGlobalPosition = GlobalPosition 17, - emitIndex = 0, - targetStreamName = StreamName "orders-42", - errorClass = "command_rejected", - errorDetail = Text.replicate 1100 "x", - attemptCount = 2 - } - Right rows <- - Store.runStoreIO storeHandle $ do - recordDispatchDeadLetter deadLetter - recordDispatchDeadLetter deadLetter - listDispatchDeadLetters "orders-pm" - case rows of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherProcessManager - row ^. #dispatcherName `shouldBe` "orders-pm" - row ^. #correlationId `shouldBe` "order-42" - row ^. #sourceEventId `shouldBe` EventId sampleUuid - row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17 - row ^. #emitIndex `shouldBe` 0 - row ^. #targetStreamName `shouldBe` StreamName "orders-42" - row ^. #errorClass `shouldBe` "command_rejected" - Text.length (row ^. #errorDetail) `shouldBe` 1024 - row ^. #attemptCount `shouldBe` 2 - other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other) - - describe "Keiro.Codec" $ do - it "encodes current events with type tags and schema-version metadata" $ do - encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) - encoded ^. #eventType `shouldBe` EventType "OrderPlaced" - encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] - extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2 - - it "round-trips current events" $ do - encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) - decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5) - - it "decodes by the stored tag, not by payload shape (H1)" $ do - let recorded = - recordedFrom - EventData - { eventId = Nothing, - eventType = EventType "CounterAudited", - payload = object ["amount" Aeson..= (5 :: Int)], - metadata = Just (metadataForOrDie 1 Nothing), - causationId = Nothing, - correlationId = Nothing - } - decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5) - - it "runs upcasters in source-version order" $ - decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) - `shouldBe` Right (OrderPlaced "order-123" 5) - - it "rejects gaps in upcaster chains" $ - decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) - `shouldBe` Left (GapInUpcasterChain 2 3) - - it "validates codec construction invariants" $ do - fmap (const ()) (mkCodec (orderCodec {schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0) - fmap (const ()) (mkCodec (orderCodec {eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]})) - `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"]) - fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]})) - `shouldBe` Left (CodecDuplicateUpcasterSources [1]) - fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]})) - `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3) - case mkCodec orderCodec of - Right _ -> pure () - Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err) - - it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do - let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)] - earlyEndCodec = - orderCodec - { schemaVersion = 4, - upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)] - } - decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload - `shouldBe` Left (VersionAhead 3 2) - decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload - `shouldBe` Left (IncompleteUpcasterChain 3 4) - - let malformedStamp = - recordedFrom - EventData - { eventId = Nothing, - eventType = EventType "OrderPlaced", - payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)], - metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]), - causationId = Nothing, - correlationId = Nothing - } - extractSchemaVersion malformedStamp - `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2")) - fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5)) - `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x")) - - it "rejects recorded events with unknown type tags" $ do - let encoded = - recordedFrom - EventData - { eventId = Nothing, - eventType = EventType "OrderCancelled", - payload = object ["orderId" Aeson..= ("order-123" :: Text)], - metadata = Just (metadataForOrDie 2 Nothing), - causationId = Nothing, - correlationId = Nothing - } - decodeRecorded orderCodec encoded - `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"]) - - describe "Keiro.Codec.Structural" $ do - let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int) - pairBinding = - StructuralBinding - { bindingToShape = \(amount, enabled) -> (enabled, amount), - bindingFromShape = \(enabled, amount) -> (amount, enabled) - } - encodePairShape (enabled, amount) = - object ["enabled" Aeson..= enabled, "amount" Aeson..= amount] - decodePairShape value = - case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of - Left err -> Left (Text.pack err) - Right shape -> Right shape - - it "checks both total binding laws" $ do - bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True - bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True - - it "delegates encoding to the generated shape codec" $ - encodeViaBinding pairBinding encodePairShape (7, True) - `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)] - - it "propagates only shape decode failures before total construction" $ do - let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)] - decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False) - decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null - `shouldBe` Left "shape-error" - - describe "Keiro.Codec.Nominal" $ do - let swappedBinding :: NominalBinding (Int, Bool) (Bool, Int) - swappedBinding = - NominalBinding - { nominalToRepresentation = \(amount, enabled) -> (enabled, amount), - nominalFromRepresentation = \(enabled, amount) -> (amount, enabled) - } - fixtures = - NominalFixtureCases - ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) - :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] - ) - - it "checks both total nominal binding laws" $ do - nominalDomainRoundTrip swappedBinding (7, True) `shouldBe` True - nominalRepresentationRoundTrip swappedBinding (False, 9) `shouldBe` True - - it "retains labelled expected-wire fixtures" $ - nominalFixtureCases fixtures - `shouldBe` ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) - :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] - ) - - describe "Keiro.EventStream" $ do - it "constructs an author-facing EventStream contract" $ do - let contract = - EventStream - { transducer = emptyTransducer, - initialState = Idle, - initialRegisters = RNil, - eventCodec = orderCodec, - resolveStreamName = \s -> Stream.streamName s, - snapshotPolicy = Never, - stateCodec = Nothing - } - typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent) - contract ^. #initialState `shouldBe` Idle - (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123" - - it "evaluates snapshot policies with explicit terminality" $ do - shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False - shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True - shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True - shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False - shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1) - `shouldBe` True - shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1) - `shouldBe` False - shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4) - `shouldBe` True - shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5) - `shouldBe` False - - it "rejects snapshot policies without a state codec" $ do - let contract :: CounterEventStream - contract = counterEventStreamDef {snapshotPolicy = Every 10, stateCodec = Nothing} - fmap (const ()) (mkEventStream "snapshotless" contract) - `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"] - - describe "EventStream replay-safety (validateEventStream)" $ do - it "every production-intent stream validates clean" $ - concat - [ validateEventStream "counter" counterEventStreamDef, - validateEventStream "counter-no-op" noOpCounterEventStreamDef, - validateEventStream "counter-multi" multiCounterEventStreamDef, - validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef, - validateEventStream "snapshot-counter" snapshotCounterEventStreamDef, - validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef, - validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef, - validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef, - validateEventStream "rejecting-counter" rejectingEventStreamDef - ] - `shouldBe` [] - - describe "mkEventStream" $ do - it "rejects duplicate upcaster sources at the stream boundary" $ do - let duplicateCodec = - counterCodec - { schemaVersion = 3, - upcasters = [(1, const Right), (1, const Right)] - } - duplicateStream = counterEventStreamDef {eventCodec = duplicateCodec} - case mkEventStream "duplicate-codec" duplicateStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec") - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1") - Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources" - - it "rejects a missing upcaster rung at the stream boundary" $ do - let incompleteCodec = - counterCodec - { schemaVersion = 3, - upcasters = [(2, const Right)] - } - incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} - case mkEventStream "incomplete-codec" incompleteStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec") - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1") - Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain" - - it "includes the stream label when throwing for an invalid codec" $ do - let incompleteCodec = - counterCodec - { schemaVersion = 3, - upcasters = [(2, const Right)] - } - incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} - result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream)) - case result of - Left err -> do - displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec" - displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1" - Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain" - - it "keeps invalid codecs available through the unchecked escape hatch" $ do - let duplicateCodec = - counterCodec - { schemaVersion = 3, - upcasters = [(1, const Right), (1, const Right)] - } - incompleteCodec = - counterCodec - { schemaVersion = 3, - upcasters = [(2, const Right)] - } - _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = duplicateCodec}) - _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = incompleteCodec}) - pure () - - it "rejects a hidden-input stream by label" $ do - let warns = validateEventStream "broken" brokenHiddenInputEventStream - warns `shouldNotBe` [] - map eswStreamLabel warns `shouldSatisfy` all (== "broken") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input") - case mkEventStream "broken" brokenHiddenInputEventStream of - Left ws -> do - map eswStreamLabel ws `shouldSatisfy` all (== "broken") - map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input") - Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream" - - it "rejects a head-unrecoverable multi-event stream" $ - expectValidationWarning - "head-unrecoverable" - "head-unrecoverable" - headUnrecoverableEventStreamDef - - it "rejects replay inversion ambiguity" $ - expectValidationWarning - "inversion-ambiguity" - "inversion-ambiguity" - inversionAmbiguousEventStreamDef - - it "rejects an unguarded command-field read" $ - expectValidationWarning - "unguarded-input-read" - "unguarded-input-read" - unguardedInputReadEventStreamDef - - it "rejects a silent edge that writes registers" $ do - Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer - `shouldSatisfy` any isStateChangingEpsilon - expectValidationWarning - "state-changing-epsilon" - "state-changing-epsilon" - stateChangingEpsilonEventStreamDef - - it "rejects a silent edge that changes vertex" $ do - Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer - `shouldSatisfy` any isStateChangingEpsilon - expectValidationWarning - "silent-move" - "state-changing-epsilon" - silentMoveEventStreamDef - - it "keeps replay-contract checks enabled when caller options weaken them" $ do - case mkEventStreamWith - Keiki.defaultValidationOptions {Keiki.checkStateChangingEpsilon = False} - "silent-move-weakened" - silentMoveEventStreamDef of - Left warnings -> - map eswReason warnings - `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") - Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check" - case mkEventStreamWith - Keiki.defaultValidationOptions {Keiki.checkHeadRecoverability = False} - "head-unrecoverable-weakened" - headUnrecoverableEventStreamDef of - Left warnings -> - map eswReason warnings - `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable") - Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check" - - it "provides a loudly named unchecked escape hatch" $ do - _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef) - pure () - - it "accepts every production-intent stream" $ do - let expectAccepted label eventStream = - case mkEventStream label eventStream of - Right _ -> pure () - Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws) - expectAccepted "counter" counterEventStreamDef - expectAccepted "counter-no-op" noOpCounterEventStreamDef - expectAccepted "counter-multi" multiCounterEventStreamDef - expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef - expectAccepted "snapshot-counter" snapshotCounterEventStreamDef - expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef - expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef - expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef - expectAccepted "rejecting-counter" rejectingEventStreamDef - - it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do - case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of - Left warns -> do - map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers") - map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten") - Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register" - - it "accepts the same snapshot stream when every initial register is initialized" $ do - case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of - Right _ -> pure () - Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns) - - it "rejects a bare EventStream at runCommand (compile-time)" $ do - (exitCode, _stdout, stderr) <- - readProcessWithExitCode - "cabal" - [ "exec", - "ghc", - "--", - "-fno-code", - "-package", - "keiro-" <> showVersion Package.version, - "test/ReplaySafetyTypeProbe.hs" - ] - "" - exitCode `shouldSatisfy` (/= ExitSuccess) - stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`) - - describe "Keiro.Command" $ around (withFreshStore fixture) $ do - describe "typed domain command outcomes" $ do - it "returns the exact ordered accepted batch and compatibility result" $ \storeHandle -> do - let target = stream "domain-command-accepted" :: Stream CounterEventStream - commandResult <- - Store.runStoreIO storeHandle $ - runDomainCommand defaultRunCommandOptions multiCounterDomainHandler target (Add 4) - case commandResult of - Right (Right outcome@DomainCommandOutcome {decision = DomainAccepted events, result}) -> do - events `shouldBe` (CounterAdded 4 :| [CounterAudited 4]) - result ^. #streamVersion `shouldBe` StreamVersion 2 - result ^. #eventsAppended `shouldBe` 2 - forgetDomainDecision outcome `shouldBe` result - other -> expectationFailure ("expected typed accepted command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "domain-command-accepted") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 4, CounterAudited 4] - - it "attributes sibling silent edges and returns typed rejection and no-op" $ \storeHandle -> do - let rejectionTarget = stream "domain-command-rejected" :: Stream SilentChoiceEventStream - noOpTarget = stream "domain-command-no-op" :: Stream SilentChoiceEventStream - rejectionResult <- - Store.runStoreIO storeHandle $ - runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler rejectionTarget RejectSilently - case rejectionResult of - Right (Right outcome@DomainCommandOutcome {decision = DomainRejected reason, result}) -> do - reason `shouldBe` "edge-0: rejected" - result ^. #eventsAppended `shouldBe` 0 - result ^. #streamVersion `shouldBe` StreamVersion 0 - result ^. #globalPosition `shouldBe` Nothing - forgetDomainDecision outcome `shouldBe` result - other -> expectationFailure ("expected typed domain rejection, got " <> show other) - noOpResult <- - Store.runStoreIO storeHandle $ - runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler noOpTarget NoOpSilently - case noOpResult of - Right (Right outcome@DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do - explanation `shouldBe` "edge-1: already complete" - result ^. #eventsAppended `shouldBe` 0 - result ^. #streamVersion `shouldBe` StreamVersion 0 - result ^. #globalPosition `shouldBe` Nothing - forgetDomainDecision outcome `shouldBe` result - other -> expectationFailure ("expected typed domain no-op, got " <> show other) - Right rejectedEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "domain-command-rejected") (StreamVersion 0) 10 - Right noOpEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "domain-command-no-op") (StreamVersion 0) 10 - rejectedEvents `shouldBe` Vector.empty - noOpEvents `shouldBe` Vector.empty - - it "keeps unmatched and ambiguous selection failures as CommandError" $ \storeHandle -> do - let unmatchedTarget = stream "domain-command-unmatched" :: Stream SilentChoiceEventStream - ambiguousTarget = stream "domain-command-ambiguous" :: Stream CounterEventStream - unmatched <- - Store.runStoreIO storeHandle $ - runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler unmatchedTarget UnmatchedSilently - ambiguous <- - Store.runStoreIO storeHandle $ - runDomainCommand defaultRunCommandOptions ambiguousCounterDomainHandler ambiguousTarget (Add 1) - unmatched `shouldBe` Right (Left CommandRejected) - ambiguous `shouldBe` Right (Left (CommandAmbiguous [0, 1])) - - it "retains validated rejection of state-changing silent edges" $ \_ -> do - case mkEventStream "domain-state-changing-epsilon" stateChangingEpsilonEventStreamDef of - Left warnings -> - map eswReason warnings - `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") - Right _ -> expectationFailure "expected validation to reject a state-changing silent edge" - - it "runs SQL once with the exact accepted event pairs" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let target = stream "domain-command-sql-accepted" :: Stream CounterEventStream - outcome <- - runner $ - runDomainCommandWithSqlEvents - defaultRunCommandOptions - multiCounterDomainHandler - target - (Add 6) - (\pairs _appendResult -> pure (Prelude.fst <$> pairs)) - case outcome of - Right - ( Right - ( DomainCommandOutcome {decision = DomainAccepted events, result}, - Just callbackEvents - ) - ) -> do - events `shouldBe` (CounterAdded 6 :| [CounterAudited 6]) - callbackEvents `shouldBe` NonEmpty.toList events - result ^. #eventsAppended `shouldBe` 2 - other -> expectationFailure ("expected accepted SQL domain command, got " <> show other) - - it "skips SQL callbacks and inline projections for rejection and no-op" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let rejectionTarget = stream "domain-command-sql-rejected" :: Stream SilentChoiceEventStream - noOpTarget = stream "domain-command-projection-no-op" :: Stream SilentChoiceEventStream - callback _ _ = error "silent domain decision invoked SQL callback" :: Tx.Transaction Text - projection = - InlineProjection - { name = "silent-domain-bomb", - apply = \_ _ -> error "silent domain decision invoked projection" - } - rejected <- - runner $ - runDomainCommandWithSqlEvents - defaultRunCommandOptions - silentChoiceDomainHandler - rejectionTarget - RejectSilently - callback - case rejected of - Right (Right (DomainCommandOutcome {decision = DomainRejected reason}, Nothing)) -> - reason `shouldBe` "edge-0: rejected" - other -> expectationFailure ("expected silent SQL rejection, got " <> show other) - noOp <- - runner $ - runDomainCommandWithProjections - defaultRunCommandOptions - silentChoiceDomainHandler - noOpTarget - NoOpSilently - [projection] - case noOp of - Right (Right DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do - explanation `shouldBe` "edge-1: already complete" - result ^. #eventsAppended `shouldBe` 0 - other -> expectationFailure ("expected silent projection no-op, got " <> show other) - - it "applies inline projections atomically for accepted domain events" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "domain-command-projection-accepted" :: Stream CounterEventStream - outcome <- - runner $ - runDomainCommandWithProjections - defaultRunCommandOptions - multiCounterDomainHandler - target - (Add 7) - [counterInlineProjection] - case outcome of - Right (Right DomainCommandOutcome {decision = DomainAccepted events}) -> - events `shouldBe` (CounterAdded 7 :| [CounterAudited 7]) - other -> expectationFailure ("expected accepted projected domain command, got " <> show other) - projected <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "inline" - projected `shouldBe` Right (Right 7) - - it "preserves catalog outcomes while skipping catalog SQL for silent decisions" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - validated <- - case validateProjectionCatalog catalogInlineProjectionCatalog of - Failure diagnostics -> - expectationFailure ("catalog fixture failed validation: " <> show diagnostics) - >> error "unreachable" - Success value -> pure value - Right () <- runner $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) - Right (Right _) <- runner $ Rebuild.registerProjectionCatalog validated - let target = stream "domain-command-catalog-rejected" :: Stream SilentChoiceEventStream - outcome <- - runner $ - runDomainCommandWithCatalogProjections - defaultRunCommandOptions - silentChoiceDomainHandler - target - RejectSilently - validated - catalogInlineProjectionSet - case outcome of - Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainRejected reason})) -> - reason `shouldBe` "edge-0: rejected" - other -> expectationFailure ("expected applied silent catalog decision, got " <> show other) - Right 0 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - let acceptedTarget = stream "domain-command-catalog-accepted" :: Stream CounterEventStream - accepted <- - runner $ - runDomainCommandWithCatalogProjections - defaultRunCommandOptions - multiCounterDomainHandler - acceptedTarget - (Add 5) - validated - catalogInlineProjectionSet - case accepted of - Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainAccepted events})) -> - events `shouldBe` (CounterAdded 5 :| [CounterAudited 5]) - other -> expectationFailure ("expected applied accepted catalog decision, got " <> show other) - Right 2 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) - Right (Right _) <- - runner $ - Rebuild.beginGroupRebuild - validated - catalogInlineGroupId - Rebuild.RebuildRequest - { rebuildRunId = catalogInlineRunId, - requestedBy = "keiro-test", - requestReason = "typed domain catalog fence proof", - replayFrom = GlobalPosition 0 - } - let fencedTarget = stream "domain-command-catalog-fenced" :: Stream CounterEventStream - fenced <- - runner $ - runDomainCommandWithCatalogProjections - defaultRunCommandOptions - multiCounterDomainHandler - fencedTarget - (Add 8) - validated - catalogInlineProjectionSet - fenced - `shouldBe` Right (Right (DomainProjectionCommandFenced catalogInlineGroupId catalogInlineRunId)) - Right recorded <- - runner $ - Store.readStreamForward (StreamName "domain-command-catalog-fenced") (StreamVersion 0) 10 - recorded `shouldBe` Vector.empty - pure () - - it "discards an accepted conflict attempt and returns the rehydrated silent decision" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - conflictInserted <- newIORef False - let target = stream "domain-command-conflict-final-no-op" :: Stream RetryDecisionEventStream - targetStreamName = StreamName "domain-command-conflict-final-no-op" - insertConflict = do - shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, not inserted) - when shouldInsert $ do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 9)) - appended <- - Store.runStoreIO storeHandle $ - Store.appendToStream targetStreamName NoStream [encoded] - case appended of - Right _ -> pure () - Left err -> expectationFailure ("failed to inject domain conflict: " <> show err) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConflict - & #retryBackoffMicros - .~ 0 - callback _ _ = error "stale accepted decision invoked SQL callback" :: Tx.Transaction Text - outcome <- - runner $ - runDomainCommandWithSqlEvents - options - retryDecisionDomainHandler - target - (Add 1) - callback - case outcome of - Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do - explanation `shouldBe` "already drained" - result ^. #streamVersion `shouldBe` StreamVersion 1 - result ^. #eventsAppended `shouldBe` 0 - other -> expectationFailure ("expected rehydrated no-op decision, got " <> show other) - readIORef conflictInserted `shouldReturn` True - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 9] - - it "records only bounded decision classes on successful spans and metrics" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions - (metricExporter, metricsRef) <- inMemoryMetricExporter - (meterProvider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just metricExporter} - meter <- getMeter meterProvider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let tracer = makeTracer tracerProvider "keiro-test" tracerOptions - options = - defaultRunCommandOptions - & #tracer - ?~ tracer - & #metrics - ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runDomainCommand options multiCounterDomainHandler (stream "domain-telemetry-accepted") (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-rejected") RejectSilently - Right (Right _) <- - Store.runStoreIO storeHandle $ - runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-no-op") NoOpSilently - _ <- shutdownTracerProvider tracerProvider Nothing - _ <- forceFlushMeterProvider meterProvider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - fmap (\sp -> textAttr (csAttributes sp) "keiro.command.decision") spans - `shouldMatchList` [Just "accepted", Just "rejected", Just "no_op"] - fmap csStatus spans `shouldSatisfy` all (== Unset) - fmap (\sp -> textAttr (csAttributes sp) "error.type") spans - `shouldSatisfy` all (== Nothing) - exported <- readIORef metricsRef - let decisionPoints = - [ (textAttr attrs "keiro.command.decision", value) - | (name, value, attrs) <- flattenScalarPointsWithAttributes exported, - name == "keiro.command.decisions" - ] - decisionPoints - `shouldMatchList` [ (Just "accepted", IntNumber 1), - (Just "rejected", IntNumber 1), - (Just "no_op", IntNumber 1) - ] - - it "keeps all five process-manager target outcomes distinguishable" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - input = - DomainDispatchInput - "five-outcomes" - [ CoordinatorAccept 3, - CoordinatorReject "private rejection", - CoordinatorNoOp "private no-op", - CoordinatorUnmatched - ] - first <- - runner $ - runDomainProcessManagerOnce - defaultRunCommandOptions - domainProcessManager - sourceEvent - input - case first of - Right (Right result) -> do - result ^. #managerResult `shouldSatisfy` \case - PMStateAppended {} -> True - _ -> False - case result ^. #commandResults of - [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation}, - DomainPMCommandFailed _ CommandRejected - ] -> do - events `shouldBe` (CounterAdded 3 :| []) - reason `shouldBe` "private rejection" - explanation `shouldBe` "private no-op" - other -> expectationFailure ("expected four fresh domain PM outcomes, got " <> show other) - other -> expectationFailure ("expected domain process-manager success, got " <> show other) - second <- - runner $ - runDomainProcessManagerOnce - defaultRunCommandOptions - domainProcessManager - sourceEvent - input - case second of - Right (Right result) -> do - result ^. #managerResult `shouldSatisfy` \case - PMStateDuplicate {} -> True - _ -> False - result ^. #commandResults `shouldSatisfy` \case - [ DomainPMCommandDuplicate {}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "private rejection"}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "private no-op"}, - DomainPMCommandFailed _ CommandRejected - ] -> True - _ -> False - other -> expectationFailure ("expected domain process-manager redelivery, got " <> show other) - - it "keeps all five router target outcomes distinguishable" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - input = - DomainDispatchInput - "five-outcomes" - [ CoordinatorAccept 4, - CoordinatorReject "router rejection", - CoordinatorNoOp "router no-op", - CoordinatorUnmatched - ] - Right (DomainRouterResult first) <- - runner $ - runDomainRouterOnce - defaultRunCommandOptions - domainRouter - sourceEvent - input - case first of - [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation}, - DomainPMCommandFailed _ CommandRejected - ] -> do - events `shouldBe` (CounterAdded 4 :| []) - reason `shouldBe` "router rejection" - explanation `shouldBe` "router no-op" - other -> expectationFailure ("expected four fresh domain router outcomes, got " <> show other) - Right (DomainRouterResult second) <- - runner $ - runDomainRouterOnce - defaultRunCommandOptions - domainRouter - sourceEvent - input - second `shouldSatisfy` \case - [ DomainPMCommandDuplicate {}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "router rejection"}, - DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "router no-op"}, - DomainPMCommandFailed _ CommandRejected - ] -> True - _ -> False - - it "acks domain rejection and no-op in coordinator workers without leaking payloads" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - processManagerDecisions <- newIORef [] - routerDecisions <- newIORef [] - let rejectionPayload = "pm-private-rejection-payload" - noOpPayload = "router-private-no-op-payload" - processManagerSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 1) - routerSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - processManagerInput = DomainDispatchInput "worker-pm" [CoordinatorReject rejectionPayload, CoordinatorNoOp "pm no-op"] - routerInput = DomainDispatchInput "worker-router" [CoordinatorReject "router rejection", CoordinatorNoOp noOpPayload] - processManagerAdapter = inMemoryAdapter processManagerDecisions [(processManagerSource, processManagerInput)] - routerAdapter = inMemoryAdapter routerDecisions [(routerSource, routerInput)] - workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics - commandOptions = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right () <- - runner $ - runDomainProcessManagerWorkerWith - workerOptions - commandOptions - domainProcessManager - processManagerAdapter - Just - Right () <- - runner $ - runDomainRouterWorkerWith - workerOptions - commandOptions - domainRouter - routerAdapter - Just - readIORef processManagerDecisions `shouldReturn` [AckOk] - readIORef routerDecisions `shouldReturn` [AckOk] - Right processManagerDeadLetters <- runner (listDispatchDeadLetters "domain-pm") - Right routerDeadLetters <- runner (listDispatchDeadLetters "domain-router") - processManagerDeadLetters `shouldBe` [] - routerDeadLetters `shouldBe` [] - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 0) - let rendered = Text.pack (show exported) - Text.isInfixOf rejectionPayload rendered `shouldBe` False - Text.isInfixOf noOpPayload rendered `shouldBe` False - - it "creates a stream and appends the first command event" $ \storeHandle -> do - let target = stream "counter-command-create" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - commandResult ^. #eventsAppended `shouldBe` 1 - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected successful command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2] - - it "reports no global position for a no-op after prior events" $ \storeHandle -> do - let target = stream "skip-command-no-op-position" :: Stream SkipEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions skipEventStream target (SAdd 2) - appended ^. #globalPosition `shouldSatisfy` isJust - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions skipEventStream target SSkip - case result of - Right (Right noOp) -> do - noOp ^. #streamVersion `shouldBe` StreamVersion 1 - noOp ^. #eventsAppended `shouldBe` 0 - noOp ^. #globalPosition `shouldBe` Nothing - other -> expectationFailure ("expected successful no-op command, got " <> show other) - - it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-ambiguous" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - result <- - Store.runStoreIO storeHandle $ - runCommand options ambiguousCounterEventStream target (Add 1) - _ <- shutdownTracerProvider provider Nothing - result `shouldBe` Right (Left (CommandAmbiguous [0, 1])) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10 - recorded `shouldBe` Vector.empty - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous" - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "rehydrates prior events before appending a second command event" $ \storeHandle -> do - let target = stream "counter-command-update" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - other -> expectationFailure ("expected successful second command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAdded 3] - - it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do - let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream - targetName = StreamName "counter-truncated-uncovered" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 3) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 3) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 4) - case result of - Right (Left (HydrationGapDetected expected observed)) -> do - expected `shouldBe` StreamVersion 1 - observed `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) - - it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do - let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream - targetName = StreamName "counter-truncated-mid-batch" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) - case result of - Right (Left (HydrationGapDetected expected observed)) -> do - expected `shouldBe` StreamVersion 1 - observed `shouldBe` StreamVersion 2 - other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) - - it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do - let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream - targetName = StreamName "counter-truncated-covered" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.setStreamTruncateBefore targetName (StreamVersion 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected snapshot-covered command success, got " <> show other) - - it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do - let target = stream "counter-command-event-id" :: Stream CounterEventStream - supplied = EventId sampleUuid2 - options = defaultRunCommandOptions & #eventIds .~ [supplied] - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 7) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - other -> expectationFailure ("expected successful command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied] - - it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do - conflictInserted <- newIORef False - let target = stream "counter-command-conflict" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-conflict" - insertConflict = do - shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> - if alreadyInserted - then (True, False) - else (True, True) - when shouldInsert $ do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName NoStream [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = defaultRunCommandOptions & #beforeAppend .~ insertConflict - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected retry to succeed, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward conflictStreamName (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 10, CounterAdded 2] - - it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-exhausted-conflict" - insertConflict = do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName AnyVersion [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConflict - & #retryLimit - .~ 2 - & #retryBackoffMicros - .~ 0 - & #metrics - ?~ keiroMetrics - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Left (RetryExhausted attempts _)) -> - attempts `shouldBe` 3 - other -> expectationFailure ("expected exhausted retry budget, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2) - - it "records the successful retry attempt on the command span" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - conflictInserted <- newIORef False - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-retry-span" :: Stream CounterEventStream - conflictStreamName = StreamName "counter-command-retry-span" - insertConflict = do - shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> - if alreadyInserted - then (True, False) - else (True, True) - when shouldInsert $ do - encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) - outcome <- - Store.runStoreIO storeHandle $ - Store.appendToStream conflictStreamName NoStream [encoded] - case outcome of - Right _ -> pure () - Left err -> expectationFailure ("failed to insert conflict event: " <> show err) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConflict - & #retryBackoffMicros - .~ 0 - & #tracer - ?~ tracer - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of - Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2 - other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other) - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "counts duplicate deterministic command events" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let supplied = EventId sampleUuid3 - first = stream "counter-command-duplicate-a" :: Stream CounterEventStream - second = stream "counter-command-duplicate-b" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #eventIds - .~ [supplied] - & #metrics - ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream first (Add 1) - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream second (Add 2) - case result of - Right (Left (StoreFailed Store.DuplicateEvent {})) -> pure () - other -> expectationFailure ("expected duplicate event failure, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #retryBackoffMicros - .~ 0 - & #metrics - ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 1) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.softDeleteStream (StreamName "counter-command-soft-deleted") - result <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 2) - case result of - Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists {})) -> pure () - other -> expectationFailure ("expected conflict fixpoint, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "surfaces decode failure during hydration" $ \storeHandle -> do - Right _ <- - Store.runStoreIO storeHandle $ - Store.appendToStream - (StreamName "counter-command-decode-failure") - NoStream - [ EventData - { eventId = Nothing, - eventType = EventType "OtherEvent", - payload = object [], - metadata = Just (metadataForOrDie 1 Nothing), - causationId = Nothing, - correlationId = Nothing - } - ] - let target = stream "counter-command-decode-failure" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"]))) - - it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-no-inverting-edge" - target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAudited 7] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) - - it "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do - let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - appended ^. #streamVersion `shouldBe` StreamVersion 1 - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) - - it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do - let target = stream "divert-black-acuity-good" :: Stream DivertEventStream - Right (Right appended) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - appended ^. #streamVersion `shouldBe` StreamVersion 1 - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> - expectationFailure ("expected hydration through the twin to succeed, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10 - traverse (decodeRecorded divertCodec) (Vector.toList recorded) - `shouldBe` Right [DivertConfirmed True, DivertConfirmed False] - - it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do - let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True) - result `shouldBe` Right (Left CommandRejected) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-queue-mismatch" - target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch)) - - it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-truncated-chain" - target = stream "counter-command-truncated-chain" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 5] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain)) - - it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do - let targetStreamName = StreamName "counter-command-ambiguous-inversion" - target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream - appendCounterEvents storeHandle targetStreamName [CounterAdded 3] - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1) - result - `shouldBe` Right - (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion)) - - it "truncates command span error status descriptions" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - longTag = Text.replicate 400 "x" - Right _ <- - Store.runStoreIO storeHandle $ - Store.appendToStream - (StreamName "counter-command-long-decode-failure") - NoStream - [ EventData - { eventId = Nothing, - eventType = EventType longTag, - payload = object [], - metadata = Just (metadataForOrDie 1 Nothing), - causationId = Nothing, - correlationId = Nothing - } - ] - let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - _ <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 1) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - case csStatus sp of - Error description -> Text.length description `shouldSatisfy` (<= 256) - other -> expectationFailure ("expected error span status, got " <> show other) - other -> expectationFailure ("expected one span, got " <> show (length other)) - - it "rolls back the append when inline SQL condemns the transaction" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - let target = stream "counter-command-rollback" :: Stream CounterEventStream - result <- - runner $ - runCommandWithSql - defaultRunCommandOptions - counterEventStream - target - (Add 1) - (\_ -> Tx.condemn >> pure ("rolled-back" :: Text)) - case result of - Right (Right (_, Just "rolled-back")) -> pure () - other -> expectationFailure ("expected condemned transaction result, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10 - recorded `shouldBe` Vector.empty - - it "appends all events emitted by one accepted command" $ \storeHandle -> do - let target = stream "counter-command-multi-create" :: Stream CounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected successful multi-event command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 5, CounterAudited 5] - - it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (metricProvider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - (processor, spansRef) <- inMemoryListExporter - tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer tracerProvider "keiro-test" tracerOptions - target = stream "counter-command-replay-divergence" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #tracer - ?~ tracer - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options headUnrecoverableEventStream target (Add 2) - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider metricProvider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - next <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3) - case next of - Right (Left HydrationReplayFailed {}) -> pure () - other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other) - _ <- shutdownTracerProvider tracerProvider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [sp] -> - textAttr (csAttributes sp) "keiro.replay.divergence" - `shouldBe` Just "event_index=0;reason=no_inverting_edge" - other -> expectationFailure ("expected one divergence span, got " <> show (length other)) - - it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #verifyReplayOnAppend - .~ False - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options headUnrecoverableEventStream target (Add 2) - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Nothing - - it "witnesses replay divergence on the transactional SQL append path" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right (commandResult, Just ())) <- - runner $ - runCommandWithSqlEvents - options - headUnrecoverableEventStream - target - (Add 2) - (\_ _ -> pure ()) - commandResult ^. #eventsAppended `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) - `shouldBe` Just (IntNumber 1) - - it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do - let target = stream "counter-command-multi-replay" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 4 - commandResult ^. #eventsAppended `shouldBe` 2 - other -> expectationFailure ("expected successful second multi-event command, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3] - - it "passes the complete multi-event batch to inline SQL in append order" $ \_ -> - withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do - let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream - result <- - runner $ - runCommandWithSqlEvents - defaultRunCommandOptions - multiCounterEventStream - target - (Add 8) - (\pairs _ -> pure (Prelude.map Prelude.fst pairs)) - case result of - Right (Right (commandResult, Just observed)) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - observed `shouldBe` [CounterAdded 8, CounterAudited 8] - other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other) - - it "command metadata is merged into stored event metadata" $ \storeHandle -> do - let target = stream "counter-command-metadata" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand opts counterEventStream target (Add 4) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10 - case Vector.toList recorded of - [event] -> - event ^. #metadata - `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)]) - other -> expectationFailure ("expected a single recorded event, got " <> show other) - - it "reconstructed RecordedEvents match the stored batch" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right (_, Just pairs)) <- - runner $ - runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps) - let reconstructed = Prelude.map Prelude.snd pairs - -- Read the stored events back from their source stream. - Right storedVec <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10 - let stored = Vector.toList storedVec - -- readStreamForward reports globalPosition 0 for stream reads, so take - -- the true global positions from a category read (the DB is fresh per - -- test, so category "counter" holds exactly this batch). - Right catVec <- - Store.runStoreIO storeHandle $ - Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10 - let catList = Vector.toList catVec - Prelude.length reconstructed `shouldBe` 2 - Prelude.length stored `shouldBe` 2 - fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored - fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored - fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored - fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored - fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored - fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored - fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored - fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList - - it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - target = stream "counter-command-otel" :: Stream CounterEventStream - options = defaultRunCommandOptions & #tracer ?~ tracer - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options counterEventStream target (Add 9) - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 1 - let sp = case spans of - (s : _) -> s - [] -> error "no command span captured" - csName sp `shouldBe` "counter-command-otel" - show (csKind sp) `shouldBe` "Internal" - textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel" - textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql" - -- keiro.events.appended is an Int64 attribute, not Text. - case lookupAttribute (csAttributes sp) "keiro.events.appended" of - Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1 - other -> expectationFailure ("expected IntAttribute 1, got " <> show other) - case csStatus sp of - Unset -> pure () - Ok -> pure () - other -> expectationFailure ("expected Unset/Ok, got " <> show other) - - describe "Keiro.Command enrichment parity" $ do - let addMarker eventData = pure (eventData & #metadata %~ injectMarker) - injectMarker = \case - Just (Aeson.Object fields) -> - Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields)) - _ -> Just (object ["enriched" Aeson..= True]) - installHook = #storeSettings . #enrichEvent ?~ addMarker - hasMarker = \case - Just (Aeson.Object fields) -> - KeyMap.lookup "enriched" fields == Just (Aeson.Bool True) - _ -> False - around (withFreshResourceStoreWith fixture installHook) $ - it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do - let plainTarget = stream "enrich-plain" :: Stream CounterEventStream - transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream - Right (Right _) <- - runner $ - runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1) - Right (Right (_, Just callbackRecordeds)) <- - runner $ - runCommandWithSqlEvents - defaultRunCommandOptions - counterEventStream - transactionalTarget - (Add 1) - (\pairs _ -> pure (fmap snd pairs)) - Right plainEvents <- - runner $ - Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10 - Right transactionalEvents <- - runner $ - Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10 - for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded -> - recorded ^. #metadata `shouldSatisfy` hasMarker - for_ callbackRecordeds $ \recorded -> - recorded ^. #metadata `shouldSatisfy` hasMarker - - describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do - it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do - result <- - encodeSnapshotStrict - (defaultStateCodec @SnapshotCounterRegs @CounterState 1) - (Counting, emptyRegFile @SnapshotCounterRegs) - case result of - Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount" - Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot" - - it "writes a snapshot after policy threshold" $ \storeHandle -> do - let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 2, CounterAdded 3] - Right snapshotVersionDuringFailure <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersionDuringFailure `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 5) - Right snapshotVersionAfterRecovery <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4) - - it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - result <- - Store.runStoreIO storeHandle $ - runCommand options partialSnapshotEventStream target (Add 7) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 1 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10 - traverse (decodeRecorded counterCodec) (Vector.toList recorded) - `shouldBe` Right [CounterAdded 7] - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing - - it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ( "snapshot-tail-hydration", - (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode) - (Counting, RCons (Proxy @"lastAmount") 4 RNil) - ) - corruptSnapshotStateStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options guardedSnapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected snapshot-assisted command, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - - it "falls back when shape hash mismatches" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected stale shape fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing - - it "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-state-shape-change" - target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - lookupResult <- - Store.runStoreIO storeHandle $ - lookupSnapshotSeed - targetStreamName - (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1) - case lookupResult of - Right (SnapshotUnavailable SnapshotNotFound) -> pure () - _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot" - - it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup" - target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream - foldV1Codec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - foldV2Codec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec - case sameFingerprint of - Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2 - _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot" - changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec - case changedFingerprint of - Right (SnapshotUnavailable SnapshotNotFound) -> pure () - _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot" - - it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do - let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1 - withFold = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1") - withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion - withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash - - it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do - let targetStreamName = "snapshot-fold-fingerprint-e2e" - target = stream targetStreamName :: Stream SnapshotCounterEventStream - candidateCodec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - case Keiki.applyEventsEither - foldV2SnapshotCounterTransducer - (Counting, RCons (Proxy @"lastAmount") 0 RNil) - [CounterAdded 2, CounterAdded 3] of - Right (_, RCons _ fullReplayLastAmount RNil) -> - fullReplayLastAmount `shouldBe` 4 - Left failure -> - expectationFailure ("expected full replay under fold v2, got " <> show failure) - candidateResult <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104) - case candidateResult of - Right (Right result) -> do - result ^. #streamVersion `shouldBe` StreamVersion 3 - result ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other) - Right storedStateShape <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetStreamName snapshotStateShapeForStreamStmt - storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash) - - it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do - let targetStreamName = StreamName "snapshot-fold-manual-contract" - target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream - unchangedCodec = - defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec - case staleSeed of - Right (SnapshotHit seed) -> - case seed ^. #registers of - RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3 - _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed" - residualResult <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104) - residualResult `shouldBe` Right (Left CommandRejected) - - it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let targetName = "snapshot-seed-sampled-divergence" - target = stream targetName :: Stream SnapshotCounterEventStream - candidateStream :: ValidatedSnapshotCounterEventStream - candidateStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-sampled" - (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #seedVerifySampleRate - .~ 1 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - result <- - Store.runStoreIO storeHandle $ - runCommand options candidateStream target (Add 4) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other) - observed <- - timeout 5_000_000 $ - let awaitDivergence = do - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of - Just (IntNumber 1) -> pure () - _ -> threadDelay 10_000 >> awaitDivergence - in awaitDivergence - observed `shouldBe` Just () - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetName snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "disables sampled seed verification at rate zero" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let targetName = "snapshot-seed-sampling-disabled" - target = stream targetName :: Stream SnapshotCounterEventStream - candidateStream :: ValidatedSnapshotCounterEventStream - candidateStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-sampling-disabled" - (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) - options = - defaultRunCommandOptions - & #metrics - ?~ keiroMetrics - & #seedVerifySampleRate - .~ 0 - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand options candidateStream target (Add 4) - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - threadDelay 100_000 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement targetName snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "falls back after operator truncation" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream - options = defaultRunCommandOptions & #metrics ?~ keiroMetrics - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "TRUNCATE keiro.keiro_snapshots" - result <- - Store.runStoreIO storeHandle $ - runCommand options snapshotCounterEventStream target (Add 4) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected truncation fallback, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing - - it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do - let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9) - case result of - Right (Right commandResult) -> do - commandResult ^. #streamVersion `shouldBe` StreamVersion 2 - commandResult ^. #eventsAppended `shouldBe` 2 - other -> expectationFailure ("expected multi-event snapshot command, got " <> show other) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do - let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream - boundaryEventStream :: SnapshotCounterEventStream - boundaryEventStream = - snapshotCounterEventStreamDef - & #transducer - .~ multiSnapshotCounterTransducer - & #snapshotPolicy - .~ Every 3 - validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2) - Right firstSnapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt - firstSnapshotVersion `shouldBe` Nothing - result <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3) - case result of - Right (Right commandResult) -> - commandResult ^. #streamVersion `shouldBe` StreamVersion 4 - other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other) - Right snapshotVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 4) - - it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do - let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4) - Right snapshotVersionBefore <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt - snapshotVersionBefore `shouldBe` Just (StreamVersion 4) - let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2 - streamId <- - Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case - Right (Just sid) -> pure sid - other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - writeSnapshotRow - SnapshotWrite - { streamId = streamId, - streamVersion = StreamVersion 2, - state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil), - stateCodecVersion = rollbackCodec ^. #stateCodecVersion, - regfileShapeHash = rollbackCodec ^. #shapeHash, - stateShapeHash = rollbackCodec ^. #stateShapeHash - } - Right snapshotVersionAfter <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt - snapshotVersionAfter `shouldBe` Just (StreamVersion 2) - - describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do - it "accepts only stream names in the configured category" $ \_ -> do - ReplayAudit.streamInCategory "counter" (StreamName "counter-one") - `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ())) - ReplayAudit.streamInCategory "counter" (StreamName "other-one") - `shouldBe` (Nothing :: Maybe (Stream ())) - - it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do - let affectedTarget = - stream "auditremove-affected" :: Stream CounterEventStream - unaffectedTarget = - stream "auditremove-unaffected" :: Stream CounterEventStream - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "CounterAdded"), - includeSnapshotStreams = False - } - budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 - candidateTarget = - ReplayAudit.AuditTarget - { eventStream = auditedCounterEventStream, - category = "auditremove", - mkStream = Just . Stream.Stream - } - deployedTarget = - ReplayAudit.AuditTarget - { eventStream = counterEventStream, - category = "auditremove", - mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9) - - Right candidateReport <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - candidateTarget - candidateReport ^. #streamsSelected `shouldBe` 1 - candidateReport ^. #streamsSkipped `shouldBe` 1 - candidateReport ^. #failures `shouldBe` 1 - candidateReport ^. #divergences `shouldBe` 0 - candidateReport ^. #rejectedStreams `shouldBe` [] - case candidateReport ^. #results of - [ ReplayAudit.StreamAuditResult - _ - ( ReplayAudit.ReplayFailed - (HydrationReplayFailed _ HydrationNoInvertingEdge) - ) - ] -> pure () - other -> - expectationFailure - ("expected a no-inverting-edge audit failure, got " <> show other) - - Right deployedReport <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - deployedTarget - ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0 - - Right eventsAfterAudit <- - Store.runStoreIO storeHandle $ - Store.readStreamForward - (StreamName "auditremove-affected") - (StreamVersion 0) - 10 - Vector.length eventsAfterAudit `shouldBe` 1 - - it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do - let target = stream "divert-audit-replay-only" :: Stream DivertEventStream - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "DivertConfirmed"), - includeSnapshotStreams = False - } - budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1 - auditWith candidate = - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - budget - ReplayAudit.AuditTarget - { eventStream = candidate, - category = "divert", - mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) - - Right withoutTwin <- - Store.runStoreIO storeHandle $ - auditWith tightenedDivertEventStream - withoutTwin ^. #results - `shouldBe` [ ReplayAudit.StreamAuditResult - (StreamName "divert-audit-replay-only") - ( ReplayAudit.ReplayFailed - (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge) - ) - ] - ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1 - - Right withTwin <- - Store.runStoreIO storeHandle $ - auditWith twinDivertEventStream - withTwin ^. #results - `shouldBe` [ ReplayAudit.StreamAuditResult - (StreamName "divert-audit-replay-only") - ReplayAudit.ReplayOk - { ReplayAudit.streamVersion = StreamVersion 1, - ReplayAudit.digest = Nothing - } - ] - ReplayAudit.auditExitCode [withTwin] `shouldBe` 0 - - it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do - let target = - stream "auditfold-stale" :: Stream SnapshotCounterEventStream - auditTarget = - ReplayAudit.AuditTarget - { eventStream = foldV2WithoutFingerprintBumpEventStream, - category = "auditfold", - mkStream = Just . Stream.Stream - } - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8) - - Right outcome <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStream auditTarget target - case outcome of - ReplayAudit.SeedDivergence - { seedVersion = StreamVersion 2, - seededDigest, - fullDigest - } -> - seededDigest `shouldNotBe` fullDigest - other -> - expectationFailure - ("expected a stale-seed divergence, got " <> show other) - - it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do - let targets = - [ stream "auditclean-one" :: Stream SnapshotCounterEventStream, - stream "auditclean-two" :: Stream SnapshotCounterEventStream - ] - affected = - ReplayAudit.AffectedSet - { affectedEventTypes = Set.singleton (EventType "CounterAdded"), - includeSnapshotStreams = False - } - auditTarget = - ReplayAudit.AuditTarget - { eventStream = snapshotCounterEventStream, - category = "auditclean", - mkStream = Just . Stream.Stream - } - unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 - for_ (zip targets [10, 20]) $ \(target, amount) -> do - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1)) - pure () - - Right firstFull <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget - Right secondFull <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget - firstFull ^. #streamsSelected `shouldBe` 2 - firstFull ^. #streamsSkipped `shouldBe` 0 - firstFull ^. #results `shouldBe` secondFull ^. #results - - Right firstPage <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - (unbounded & #maxStreams ?~ 1) - auditTarget - firstPage ^. #streamsSelected `shouldBe` 1 - firstPage ^. #checkpoint `shouldSatisfy` isJust - Right secondPage <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - ( unbounded - & #maxStreams - ?~ 1 - & #resumeFrom - .~ (firstPage ^. #checkpoint) - ) - auditTarget - secondPage ^. #streamsSelected `shouldBe` 1 - let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results) - secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results) - Set.disjoint firstNames secondNames `shouldBe` True - firstNames <> secondNames - `shouldBe` Set.fromList (Stream.streamName <$> targets) - - Right targeted <- - Store.runStoreIO storeHandle $ - ReplayAudit.auditStreams - (ReplayAudit.AuditTargeted affected) - unbounded - auditTarget - targeted ^. #results `shouldBe` firstFull ^. #results - - describe "Keiro.Connection projection schema" $ - around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do - it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do - -- qualifiedTableName builds the app's fully-qualified data table ref. - qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\"" - - -- Create the app schema (opt-in) and the qualified read-model table. - Right () <- - Store.runStoreIO storeHandle $ do - ensureProjectionSchema "app_reads" - initializeRegisteredReadModel placedReadModel initializePlacedTable - - -- Drive a command with the inline projection that writes the app table. - let target = stream "placed-in-app-reads" :: Stream CounterEventStream - result <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 7) - [placedInlineProjection] - case result of - Right (Right _) -> pure () - other -> expectationFailure ("expected placed inline projection command, got " <> show other) - - -- Read it back through the configured-schema read model. - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing placedReadModel "placed" - queryResult `shouldBe` Right (Right 7) - - -- Prove placement: the app table is in app_reads, NOT in kiroku, and - -- Keiro's own metadata (keiro_read_models) is in the keiro schema. - Right (inApp, inKiroku, keiroMeta) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - (,,) - <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt - <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt - <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt - inApp `shouldBe` (1 :: Int) - inKiroku `shouldBe` (0 :: Int) - keiroMeta `shouldBe` (1 :: Int) - - describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do - it "queries inline projection with Eventual consistency" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-inline" :: Stream CounterEventStream - result <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 5) - [counterInlineProjection] - case result of - Right (Right commandResult) -> - commandResult ^. #globalPosition `shouldSatisfy` isJust - other -> expectationFailure ("expected inline projection command, got " <> show other) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "inline" - queryResult `shouldBe` Right (Right 5) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness Nothing Immediate counterImmediateReadModel "inline" - truthfulResult `shouldBe` queryResult - - it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt - Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt - position <- - Store.runStoreIO storeHandle $ - readSubscriptionPosition "counter-read-model-sub" - position `shouldBe` Right (Just (GlobalPosition 3)) - - it "returns no subscription position for an empty durable inventory" $ \_ -> do - let inventory = - KirokuSub.SubscriptionCheckpointInventory - (GlobalPosition 17) - Vector.empty - subscriptionPositionFromInventory (SubscriptionName "missing") inventory - `shouldBe` Nothing - - it "returns the newest visible position after a stream is hard deleted" $ \storeHandle -> do - let target = stream "read-model-captured-head" :: Stream CounterEventStream - Right (Right commandResult) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - capturedPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.hardDeleteStream (StreamName "read-model-captured-head") - observedHead <- Store.runStoreIO storeHandle storeHeadPosition - observedHead `shouldBe` Right (GlobalPosition 0) - Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <- - Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory - authoritativePosition `shouldBe` capturedPosition - - it "Strong returns immediately on an empty log" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "empty" - queryResult `shouldBe` Right (Right 0) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForHead EntireVisibleLog) - counterCursorReadModel - "empty" - truthfulResult `shouldBe` queryResult - - it "rejects truthful waits when an immediate inline model has no cursor" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForHead EntireVisibleLog) - counterImmediateReadModel - "inline" - queryResult - `shouldBe` Right - ( Left - ( ReadModelMissingCursor - "counter-read-model" - (WaitForHead EntireVisibleLog) - ) - ) - - it "waitFor fails fast on a cursorless model instead of burning the timeout" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - startedAt <- getCurrentTime - waitResult <- - Store.runStoreIO storeHandle $ - waitFor (Just keiroMetrics) defaultHeadWaitOptions counterImmediateReadModel (GlobalPosition 5) - finishedAt <- getCurrentTime - waitResult - `shouldBe` Right - ( Left - ( ReadModelMissingCursor - "counter-read-model" - (WaitForPosition (defaultHeadWaitOptions & #target ?~ GlobalPosition 5)) - ) - ) - diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing - - it "deprecated Strong and PositionWait overrides fail fast on a cursorless model" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable - let target = stream "read-model-cursorless-strong" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 5) - startedAt <- getCurrentTime - strongResult <- - Store.runStoreIO storeHandle $ - runQueryWith (Just keiroMetrics) Strong counterImmediateReadModel "inline" - finishedAt <- getCurrentTime - strongResult - `shouldBe` Right - (Left (ReadModelMissingCursor "counter-read-model" (WaitForHead EntireVisibleLog))) - diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness Nothing (WaitForHead EntireVisibleLog) counterImmediateReadModel "inline" - truthfulResult `shouldBe` strongResult - positionResult <- - Store.runStoreIO storeHandle $ - runQueryWith - (Just keiroMetrics) - (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterImmediateReadModel - "inline" - positionResult - `shouldBe` Right - ( Left - ( ReadModelMissingCursor - "counter-read-model" - (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - ) - ) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing - - it "Strong returns immediately when the subscription is already at the store head" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-strong-at-head" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 5) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - queryResult `shouldBe` Right (Right 5) - - it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-strong-blocking" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 6) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - _ <- forkIO $ do - threadDelay 20000 - advanced <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - case advanced of - Right () -> pure () - Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err) - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - queryResult `shouldBe` Right (Right 6) - - it "Strong and WaitForHead return promptly after workflow GC hard-deletes the newest events" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - (stream "read-model-gc-strong" :: Stream CounterEventStream) - (Add 5) - [counterInlineProjection] - visiblePosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("counter-read-model-sub", globalPositionToInt visiblePosition) - upsertSubscriptionCursorStmt - - counter <- newIORef (0 :: Int) - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) - (WorkflowName "gc-strong-wf") - (WorkflowId "gsw-1") - (demoWorkflow counter) - now <- getCurrentTime - Right summary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} - - observedHead <- Store.runStoreIO storeHandle storeHeadPosition - observedHead `shouldBe` Right visiblePosition - Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <- - Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory - authoritativePosition `shouldSatisfy` (> visiblePosition) - - startedAt <- getCurrentTime - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - finishedAt <- getCurrentTime - queryResult `shouldBe` Right (Right 5) - diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) - - truthfulStartedAt <- getCurrentTime - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForHead EntireVisibleLog) - counterCursorReadModel - "inline" - truthfulFinishedAt <- getCurrentTime - truthfulResult `shouldBe` queryResult - diffUTCTime truthfulFinishedAt truthfulStartedAt `shouldSatisfy` (< 2) - - it "Strong and WaitForHead still time out when visible events outrun the subscription" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - (stream "read-model-strong-visible-behind" :: Stream CounterEventStream) - (Add 5) - [counterInlineProjection] - visiblePosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterReadModel "inline" - queryResult - `shouldBe` Right - ( Left - ( ReadModelWaitTimeout - "counter-read-model" - visiblePosition - (GlobalPosition 0) - ) - ) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForHead EntireVisibleLog) - counterCursorReadModel - "inline" - truthfulResult `shouldBe` queryResult - - it "Strong and WaitForHead return when their category is caught up despite another active category" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream - otherTarget = stream "otherload-1" :: Stream CounterEventStream - Right (Right counterResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - counterTarget - (Add 8) - [counterInlineProjection] - counterPosition <- case counterResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected counter global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("counter-read-model-sub", globalPositionToInt counterPosition) - upsertSubscriptionCursorStmt - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1) - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith Nothing Strong counterCategoryReadModel "inline" - queryResult `shouldBe` Right (Right 8) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForHead (CategoryVisibleHead "counter")) - counterCursorReadModel - "inline" - truthfulResult `shouldBe` queryResult - - it "inline projection populates actor and source_event_id from command metadata" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-inline-metadata" :: Stream CounterEventStream - opts = - defaultRunCommandOptions - & #metadata - ?~ object ["actor" Aeson..= ("agent-7" :: Text)] - Right (Right _) <- - runner $ - runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection] - Right row <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt) - -- selectCounterMetaStmt returns (amount, actor, source_event_id). - row `shouldSatisfy` \(amount, actor, srcId) -> - amount == 5 && actor == Just "agent-7" && isJust srcId - - it "waits for async projection cursor with PositionWait" $ \_ -> - withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-position-wait" :: Stream CounterEventStream - Right (Right commandResult) <- - runner $ - runCommandWithProjections - defaultRunCommandOptions - counterEventStream - target - (Add 3) - [counterInlineProjection] - globalPosition <- case commandResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected command global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - Nothing - (PositionWait (fastWaitOptions & #target .~ Just globalPosition)) - counterReadModel - "inline" - queryResult `shouldBe` Right (Right 3) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForPosition (fastWaitOptions & #target .~ Just globalPosition)) - counterCursorReadModel - "inline" - truthfulResult `shouldBe` queryResult - - it "times out when PositionWait target is not reached" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - Nothing - (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterReadModel - "timeout" - queryResult - `shouldBe` Right - (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) - truthfulResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterCursorReadModel - "timeout" - truthfulResult `shouldBe` queryResult - - it "rejects a truthful position wait without a target" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterCursorReadModel initializeCounterReadModelTable - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWithFreshness - Nothing - (WaitForPosition fastWaitOptions) - counterCursorReadModel - "missing-target" - queryResult - `shouldBe` Right (Left (ReadModelMissingPosition "counter-read-model")) - - it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "no-churn" - Right xminBefore <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "counter-read-model" readModelXminStmt - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "no-churn" - Right xminAfter <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "counter-read-model" readModelXminStmt - xminAfter `shouldBe` xminBefore - - it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do - let unregistered :: ReadModel Text Int - unregistered = counterReadModel & #name .~ ("never-registered" :: Text) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing unregistered "missing" - queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered")) - found <- - Store.runStoreIO storeHandle $ - lookupReadModel "never-registered" - found `shouldBe` Right Nothing - - it "handles concurrent explicit read-model registration" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction initializeCounterReadModelTable - resultA <- newEmptyMVar - resultB <- newEmptyMVar - _ <- - forkIO $ - Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) - >>= putMVar resultA - _ <- - forkIO $ - Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) - >>= putMVar resultB - first <- takeMVar resultA - second <- takeMVar resultB - first `shouldBe` Right () - second `shouldBe` Right () - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "concurrent" - queryResult `shouldBe` Right (Right 0) - - it "rejects stale read-model schema" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "stale" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "stale" - queryResult - `shouldBe` Right - (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1")) - - it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right (Right 0) <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "unknown-status" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "unknown-status" - queryResult - `shouldBe` Right - (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged"))) - - it "ignores duplicate async event by source_event_id" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-async-idempotent" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right outcomes <- Store.runStoreIO storeHandle $ - Store.runTransaction $ do - first <- applyAsyncProjection counterAsyncProjection event - second <- applyAsyncProjection counterAsyncProjection event - pure (first, second) - outcomes `shouldBe` (AsyncApplied, AsyncDuplicate) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult `shouldBe` Right (Right 7) - - it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction initializeProjectionDedupCounterTable - Right _ <- - Store.runStoreIO storeHandle $ - registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1" - let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - let incrementingProjection = - AsyncProjection - { name = "incrementing-async-projection", - readModelName = "projection-dedup-counter-model", - subscriptionName = "incrementing-async-projection-sub", - applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt, - idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId - } - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right AsyncDuplicate <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right countAfterDuplicate <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement () selectProjectionDedupCounterStmt - countAfterDuplicate `shouldBe` 1 - cutoff <- addUTCTime 1 <$> getCurrentTime - pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff - pruned `shouldBe` Right 1 - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection incrementingProjection event - Right countAfterPrune <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement () selectProjectionDedupCounterStmt - countAfterPrune `shouldBe` 2 - - it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ( "counter-read-model-sub", - globalPositionToInt (event ^. #globalPosition) - ) - upsertSubscriptionCursorStmt - beforeRebuild <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - beforeRebuild `shouldBe` Right (Right 7) - - Right rebuilding <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - rebuilding ^. #status `shouldBe` Rebuilding - checkpointAfterReset <- - Store.runStoreIO storeHandle $ - readSubscriptionPosition "counter-read-model-sub" - checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0)) - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjectionUnfenced counterAsyncProjection event - Right (Right live) <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - live ^. #status `shouldBe` Live - - afterRebuild <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - afterRebuild `shouldBe` Right (Right 7) - - it "startRebuild on a cursorless model skips the checkpoint reset and completes" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel - counterCursorlessRebuildReadModel - initializeCounterReadModelTable - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.sql "INSERT INTO counter_read_model (model_id, amount, last_seen) VALUES ('inline', 9, 1)" - Tx.statement ("counter-read-model-sub", 7) upsertSubscriptionCursorStmt - rebuildingResult <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0) - rebuilding <- case rebuildingResult of - Right metadata -> pure metadata - Left err -> expectationFailure ("cursorless startRebuild failed: " <> show err) *> error "unreachable" - rebuilding ^. #status `shouldBe` Rebuilding - untouched <- - Store.runStoreIO storeHandle $ - readSubscriptionPosition "counter-read-model-sub" - untouched `shouldBe` Right (Just (GlobalPosition 7)) - Right (Right live) <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0) - live ^. #status `shouldBe` Live - afterRebuild <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterCursorlessRebuildReadModel "inline" - afterRebuild `shouldBe` Right (Right 0) - - it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - finishResult <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - case finishResult of - Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do - modelName `shouldBe` "counter-read-model" - headPosition `shouldSatisfy` (> GlobalPosition 0) - other -> expectationFailure ("expected zero-apply guard, got " <> show other) - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult - `shouldBe` Right - (Left (ReadModelNotLive "counter-read-model" Rebuilding)) - - it "fences live async application while a model is rebuilding" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-fenced-apply" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - outcome <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - outcome `shouldBe` Right AsyncFenced - Right dedupCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt - dedupCount `shouldBe` 0 - Right amount <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "async-idempotent" selectCounterReadModelStmt - amount `shouldBe` 0 - - it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-fence-race" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 7) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10 - event <- case Vector.toList recorded of - [onlyEvent] -> pure onlyEvent - other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" - enterRebuildWindow <- newEmptyMVar - liveApplyResult <- newEmptyMVar - _ <- - forkIO $ do - takeMVar enterRebuildWindow - Store.runStoreIO - storeHandle - (Store.runTransaction (applyAsyncProjection counterAsyncProjection event)) - >>= putMVar liveApplyResult - Right _ <- - Store.runStoreIO storeHandle $ - Rebuild.startRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - putMVar enterRebuildWindow () - takeMVar liveApplyResult `shouldReturn` Right AsyncFenced - - Right AsyncApplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjectionUnfenced counterAsyncProjection event - Right (Right _) <- - Store.runStoreIO storeHandle $ - Rebuild.finishRebuild - counterReadModel - [counterAsyncProjection ^. #name] - (GlobalPosition 0) - cutoff <- addUTCTime 1 <$> getCurrentTime - pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff - pruned `shouldBe` Right 1 - reapplied <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - applyAsyncProjection counterAsyncProjection event - reapplied `shouldBe` Right AsyncApplied - queryResult <- - Store.runStoreIO storeHandle $ - runQuery Nothing counterReadModel "async-idempotent" - queryResult `shouldBe` Right (Right 7) - - it "tracks rebuild state transitions" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - registerReadModelDefinition counterReadModel - Right rebuilding <- - Store.runStoreIO storeHandle $ - Rebuild.rebuild counterReadModel - rebuilding ^. #status `shouldBe` Rebuilding - Right live <- - Store.runStoreIO storeHandle $ - Rebuild.promote counterReadModel - live ^. #status `shouldBe` Live - Right abandoned <- - Store.runStoreIO storeHandle $ - Rebuild.abandonRebuild counterReadModel - abandoned ^. #status `shouldBe` Abandoned - - it "records matching global position distance and projection lag gauges" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - let target = stream "read-model-lag" :: Stream CounterEventStream - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand defaultRunCommandOptions counterEventStream target (Add 1) - -- The subscription cursor is never advanced, so both the preferred and - -- compatibility gauges record the same non-negative position distance. - Right () <- - Store.runStoreIO storeHandle $ - recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - preferred = lookup "keiro.projection.global_position_distance" scalars - compatibility = lookup "keiro.projection.lag" scalars - preferred `shouldBe` compatibility - case preferred of - Just (IntNumber n) -> n `shouldSatisfy` (>= 1) - other -> expectationFailure ("expected an integer global position distance, got " <> show other) - - it "reports zero global position distance after the newest events are hard deleted" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right (Right survivorResult) <- - Store.runStoreIO storeHandle $ - runCommand - defaultRunCommandOptions - counterEventStream - (stream "gauge-gc-survivor" :: Stream CounterEventStream) - (Add 1) - survivorPosition <- case survivorResult ^. #globalPosition of - Just position -> pure position - Nothing -> expectationFailure "expected survivor global position" *> error "unreachable" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("counter-read-model-sub", globalPositionToInt survivorPosition) - upsertSubscriptionCursorStmt - Right (Right _) <- - Store.runStoreIO storeHandle $ - runCommand - defaultRunCommandOptions - counterEventStream - (stream "gauge-gc-victim" :: Stream CounterEventStream) - (Add 1) - Right (Just _) <- - Store.runStoreIO storeHandle $ - Store.hardDeleteStream (StreamName "gauge-gc-victim") - Right () <- - Store.runStoreIO storeHandle $ - recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.projection.global_position_distance" scalars - `shouldBe` Just (IntNumber 0) - lookup "keiro.projection.lag" scalars - `shouldBe` Just (IntNumber 0) - - it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt - queryResult <- - Store.runStoreIO storeHandle $ - runQueryWith - (Just keiroMetrics) - (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) - counterReadModel - "timeout" - queryResult - `shouldBe` Right - (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- The single give-up bumped the counter exactly once. - lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1) - - describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do - it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - case pmResult ^. #managerResult of - PMStateAppended managerResult -> - managerResult ^. #streamVersion `shouldBe` StreamVersion 1 - other -> expectationFailure ("expected appended manager state, got " <> show other) - case pmResult ^. #commandResults of - [PMCommandAppended commandResult] -> - commandResult ^. #eventsAppended `shouldBe` 1 - other -> expectationFailure ("expected one emitted command, got " <> show other) - pmResult ^. #timersScheduled `shouldBe` 1 - other -> expectationFailure ("expected process-manager success, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 1 - Vector.length targetEvents `shouldBe` 1 - timer <- - _runner $ - claimDueTimer dueTimerTime - case timer of - Right (Just row) -> do - row ^. #processManagerName `shouldBe` "counter-pm" - row ^. #correlationId `shouldBe` "order-1" - other -> expectationFailure ("expected scheduled timer row, got " <> show other) - - it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - case pmResult ^. #managerResult of - PMStateAppended managerResult -> do - managerResult ^. #streamVersion `shouldBe` StreamVersion 0 - managerResult ^. #eventsAppended `shouldBe` 0 - other -> expectationFailure ("expected no-op manager state, got " <> show other) - pmResult ^. #commandResults `shouldBe` [] - pmResult ^. #timersScheduled `shouldBe` 1 - other -> expectationFailure ("expected process-manager success, got " <> show other) - dueCount <- - _runner $ - countDueTimers dueTimerTime - dueCount `shouldBe` Right 1 - timer <- - _runner $ - claimDueTimer dueTimerTime - case timer of - Right (Just row) -> do - row ^. #processManagerName `shouldBe` "timer-only-pm" - row ^. #correlationId `shouldBe` "order-1" - other -> expectationFailure ("expected scheduled timer row, got " <> show other) - - it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) - duplicate <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) - case duplicate of - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateDuplicate {} -> True - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandDuplicate {}] -> True - _ -> False - other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 1 - Vector.length targetEvents `shouldBe` 1 - - it "bridges a pre-UTF-8 process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - correlationId = "\x4E2D\x6587-42" - managerStreamName = StreamName "pm:counter-unicode" - targetStreamName = StreamName "counter-target-unicode" - legacyManagerId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) (-1) - legacyCommandId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) 0 - appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 9) - appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9) - Right (Right pmResult) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions unicodeCounterProcessManager sourceEvent (CounterAdded 9) - Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10 - Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 - ( pmResult ^. #managerResult, - pmResult ^. #commandResults, - Vector.length managerEvents, - Vector.length targetEvents - ) - `shouldBe` ( PMStateDuplicate legacyManagerId, - [PMCommandDuplicate legacyCommandId], - 1, - 1 - ) - - it "bridges a pre-UTF-8 domain process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - correlationId = "\x4E2D\x6587-9" - managerStreamName = StreamName ("domain-pm:" <> correlationId) - targetStreamName = StreamName ("domain-pm-target:" <> correlationId <> ":0") - legacyManagerId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) (-1) - legacyCommandId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) 0 - input = DomainDispatchInput correlationId [CoordinatorAccept 9] - appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 1) - appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9) - Right (Right pmResult) <- - _runner $ - runDomainProcessManagerOnce defaultRunCommandOptions domainProcessManager sourceEvent input - Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10 - Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 - ( pmResult ^. #managerResult, - pmResult ^. #commandResults, - Vector.length managerEvents, - Vector.length targetEvents - ) - `shouldBe` ( PMStateDuplicate legacyManagerId, - [DomainPMCommandDuplicate legacyCommandId], - 1, - 1 - ) - - it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do - let subName = SubscriptionName "counter-pm-replay-fresh" - replayHandler recorded = - case decodeRecorded counterCodec recorded of - Left err -> pure (Left (Text.pack (show err))) - Right input -> do - outcome <- - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - recorded - input - pure $ - case outcome of - Left err -> Left (Text.pack (show err)) - Right result -> Right (classifyProcessManagerReplay result) - source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7) - Right listed <- _runner (listSubscriptionDeadLetters subName 0) - Vector.length listed `shouldBe` 1 - - Right firstPass <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - firstPass - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition, - replayEventId = source ^. #eventId, - replayResult = ReplayedFresh - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) - - Right secondPass <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - secondPass - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition, - replayEventId = source ^. #eventId, - replayResult = ReplayedDuplicate - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) - Right retained <- _runner (listSubscriptionDeadLetters subName 0) - Vector.length retained `shouldBe` 1 - - it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do - let subName = SubscriptionName "counter-pm-replay-duplicate" - replayHandler recorded = - case decodeRecorded counterCodec recorded of - Left err -> pure (Left (Text.pack (show err))) - Right input -> do - outcome <- - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - recorded - input - pure $ - case outcome of - Left err -> Left (Text.pack (show err)) - Right result -> Right (classifyProcessManagerReplay result) - source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8) - Right (Right _) <- - _runner $ - runProcessManagerOnce - defaultRunCommandOptions - counterProcessManager - source - (CounterAdded 8) - countsBefore <- processManagerReplayCounts _storeHandle - - Right outcomes <- - _runner $ - replaySubscriptionDeadLetters subName 0 replayHandler - outcomes - `shouldBe` [ ReplayOutcome - { replayGlobalPosition = source ^. #globalPosition, - replayEventId = source ^. #eventId, - replayResult = ReplayedDuplicate - } - ] - processManagerReplayCounts _storeHandle `shouldReturn` countsBefore - - it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6) - fulfillmentManager = - workflowProcessManager - "fulfillment-pm" - "pm:fulfillment" - "fulfillment-target-order-1" - billingManager = - workflowProcessManager - "billing-pm" - "pm:billing" - "billing-target-order-1" - fulfillmentResult <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6) - billingResult <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6) - assertWorkflowProcessManagerAppended fulfillmentResult - assertWorkflowProcessManagerAppended billingResult - - Right fulfillmentManagerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10 - Right billingManagerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10 - Right fulfillmentTargetEvents <- - _runner $ - Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10 - Right billingTargetEvents <- - _runner $ - Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10 - Vector.length fulfillmentManagerEvents `shouldBe` 1 - Vector.length billingManagerEvents `shouldBe` 1 - Vector.length fulfillmentTargetEvents `shouldBe` 1 - Vector.length billingTargetEvents `shouldBe` 1 - - Right fulfillmentCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10 - Right billingCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10 - Right sharedPmCategoryEvents <- - _runner $ - Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10 - Right sharedPmNamespaceEvents <- - _runner $ - Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10 - Vector.length fulfillmentCategoryEvents `shouldBe` 1 - Vector.length billingCategoryEvents `shouldBe` 1 - sharedPmCategoryEvents `shouldBe` Vector.empty - sharedPmNamespaceEvents `shouldBe` Vector.empty - - it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just - decisions <- readIORef decisionsRef - decisions `shouldBe` [AckOk] - - it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - Right () <- - _runner $ - runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 0 - Vector.length managerEvents `shouldBe` 1 - - it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = [(first, CounterAdded 9), (second, CounterAdded 1)] - adapter = inMemoryAdapter decisionsRef messages - policyPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectNineEventStream - } - workerOptions = - defaultWorkerOptions - & #rejectedCommandPolicy - .~ RejectedDeadLetter - & #metrics - ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk, AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - case deadLetters of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherProcessManager - row ^. #correlationId `shouldBe` "order-1" - row ^. #sourceEventId `shouldBe` EventId sampleUuid - row ^. #emitIndex `shouldBe` 0 - row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1" - row ^. #errorClass `shouldBe` "command_rejected" - row ^. #attemptCount `shouldBe` 1 - other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - Vector.length managerEvents `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = - defaultWorkerOptions - & #rejectedCommandPolicy - .~ RejectedSkip - & #metrics - ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - deadLetters `shouldBe` [] - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] - rejectingManager = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { eventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - case deadLetters of - [row] -> do - row ^. #emitIndex `shouldBe` (-1) - row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1" - row ^. #errorClass `shouldBe` "command_rejected" - other -> expectationFailure ("expected one manager-state dead letter, got " <> show other) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 - managerEvents `shouldBe` Vector.empty - - it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)] - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - readIORef decisionsRef `shouldReturn` [AckOk, AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") - Prelude.length deadLetters `shouldBe` 1 - - it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - messages = [(sourceEvent, CounterAdded 9)] - adapter = inMemoryAdapter decisionsRef messages - rejectingPm = - (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) - { targetEventStream = rejectingEventStream - } - workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics - Right () <- - _runner $ - runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) - - it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do - isRejectionClass CommandRejected `shouldBe` True - isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True - isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False - ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom")) - `shouldBe` AckRetry (RetryDelay 5) - -- kiroku-store 0.8.0.0 types class-40 rollbacks separately from - -- UnexpectedServerError. The transaction rolled back completely and - -- nothing was committed, so the source event retries rather than halting - -- the subscription; every other server code still halts. - ackForCommandError - (RetryDelay 5) - (StoreFailed (Store.TransientTransactionFailure "40001" "could not serialize access")) - `shouldBe` AckRetry (RetryDelay 5) - ackForCommandError - (RetryDelay 5) - (StoreFailed (Store.TransientTransactionFailure "40P01" "deadlock detected")) - `shouldBe` AckRetry (RetryDelay 5) - ackForCommandError (RetryDelay 5) (StoreFailed (Store.UnexpectedServerError "XX000" "boom")) - `shouldSatisfy` \case - AckHalt (HaltFatal _) -> True - _ -> False - ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case - AckHalt (HaltFatal _) -> True - _ -> False - ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case - AckHalt (HaltFatal _) -> True - _ -> False - - it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do - let badMessages = ["not-decodable" :: Text] - defaultDecisions <- newIORef [] - Right () <- - _runner $ - runProcessManagerWorker - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter defaultDecisions badMessages) - (const Nothing) - defaultObserved <- readIORef defaultDecisions - defaultObserved `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - skippedRef <- newIORef [] - skipDecisions <- newIORef [] - let skipOptions = - defaultWorkerOptions - & #poisonPolicy - .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload]))) - Right () <- - _runner $ - runProcessManagerWorkerWith - skipOptions - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter skipDecisions badMessages) - (const Nothing) - readIORef skipDecisions `shouldReturn` [AckOk] - readIORef skippedRef `shouldReturn` badMessages - - deadLetterDecisions <- newIORef [] - deadLetterRef <- newIORef [] - let deadLetterOptions = - defaultWorkerOptions - & #poisonPolicy - .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload]))) - Right () <- - _runner $ - runProcessManagerWorkerWith - deadLetterOptions - defaultRunCommandOptions - counterProcessManager - (inMemoryAdapter deadLetterDecisions badMessages) - (const Nothing) - deadLetterObserved <- readIORef deadLetterDecisions - deadLetterObserved `shouldSatisfy` \case - [AckDeadLetter (InvalidPayload _)] -> True - _ -> False - readIORef deadLetterRef `shouldReturn` badMessages - - it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0 - targetStreamName = StreamName "counter-target-order-1" - insertConcurrentTarget = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentTarget - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandDuplicate duplicateId] -> duplicateId == commandId - _ -> False - other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1) - managerStreamName = StreamName "pm:counter-order-1" - insertConcurrentManager = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentManager - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) - case result of - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateDuplicate duplicateId -> duplicateId == managerId - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandAppended {}] -> True - _ -> False - other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other) - - describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do - it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-mismatch" - ourId = EventId sampleUuid - otherId = EventId sampleUuid2 - appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just otherId))) - outcome `shouldBe` Right False - - it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-target" - otherStreamName = StreamName "duplicate-confirmation-other" - ourId = EventId sampleUuid - targetEventId = EventId sampleUuid2 - appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1) - appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just ourId))) - outcome `shouldBe` Right False - - it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-present" - ourId = EventId sampleUuid - appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) - matchingOutcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent (Just ourId))) - missingDetailOutcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.DuplicateEvent Nothing)) - matchingOutcome `shouldBe` Right True - missingDetailOutcome `shouldBe` Right True - - it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do - let targetStreamName = StreamName "duplicate-confirmation-non-duplicate" - ourId = EventId sampleUuid - appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) - outcome <- - _runner $ - confirmBenignDuplicate - targetStreamName - ourId - (StoreFailed (Store.ConnectionLost "boom")) - outcome `shouldBe` Right False - - describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do - it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do - -- Two distinct source events, both correlating to "order-1", drive the one - -- manager instance to manager-stream version 2, which Every 2 snapshots. - let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) - sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) - Right managerEvents <- - _runner $ - Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10 - Vector.length managerEvents `shouldBe` 2 - Right snapshotVersion <- - _runner $ - Store.runTransaction $ - Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - - it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do - -- After the threshold snapshot exists, a third reaction should land on top of - -- the snapshot at version 3 rather than replaying from version 0. - let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) - sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) - sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) - Right (Right _) <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) - -- Confirm the snapshot is present before the tail-replay reaction. - Right snapshotVersion <- - _runner $ - Store.runTransaction $ - Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt - snapshotVersion `shouldBe` Just (StreamVersion 2) - result <- - _runner $ - runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4) - case result of - Right (Right pmResult) -> - case pmResult ^. #managerResult of - PMStateAppended managerResult -> - managerResult ^. #streamVersion `shouldBe` StreamVersion 3 - other -> expectationFailure ("expected appended manager state, got " <> show other) - other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other) - - describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do - it "RouterSelection validates positive runtime invariants" $ \(_storeHandle, StoreRunner _runner) -> do - mkRecipientLimit 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False - mkSelectionVersion 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False - limit <- shouldBeRight (mkRecipientLimit 2) - selectionVersion <- shouldBeRight (mkSelectionVersion 3) - recipientLimitValue limit `shouldBe` 2 - selectionVersionValue selectionVersion `shouldBe` 3 - - it "RouterSelection sorts, deduplicates, caps, and rejects conflicts before dispatch" $ \(_storeHandle, StoreRunner _runner) -> do - limit <- shouldBeRight (mkRecipientLimit 2) - one <- shouldBeRight (mkRecipientLimit 1) - let targetA = PMCommand {target = stream "selection-a", command = Add 1} - targetB = PMCommand {target = stream "selection-b", command = Add 1} - targetBConflict = PMCommand {target = stream "selection-b", command = Add 2} - normalizeRecipients limit [targetB, targetA, targetB] - `shouldBe` Right [targetA, targetB] - normalizeRecipients limit [targetB, targetBConflict, targetA] - `shouldBe` Left (SelectionConflictingCommands (StreamName "selection-b")) - normalizeRecipients one [targetB, targetA, targetB] - `shouldBe` Left (SelectionRecipientOverflow one 2) - normalizeRecipients limit [targetB, targetA] - `shouldBe` Right [targetA, targetB] - - it "RouterSelection exposes stable public dead-letter code, detail, and rendering" $ \(_storeHandle, StoreRunner _runner) -> do - contract <- testSelectionContract EmptyDeadLetter FailureDeadLetter 4 - recipientLimit <- shouldBeRight (mkRecipientLimit 4) - let failures = - [ (SelectionQueryFailed "secret backend detail", "keiro.router.selection.query_failed"), - (SelectionEvaluationFailed "secret payload", "keiro.router.selection.evaluation_failed"), - (SelectionConflictingCommands (StreamName "hospital-1"), "keiro.router.selection.target_conflict"), - (SelectionRecipientOverflow recipientLimit 5, "keiro.router.selection.recipient_overflow") - ] - assertReason expectedCode reason = do - deadLetterCodeText (deadLetterReasonCode reason) `shouldBe` expectedCode - deadLetterReasonDetail reason `shouldSatisfy` maybe False (not . Text.null) - renderDeadLetterReason reason `shouldSatisfy` Text.isPrefixOf (expectedCode <> ": ") - assertReason "keiro.router.selection.empty" (emptySelectionDeadLetterReason contract) - for_ failures $ \(failure, expectedCode) -> do - let reason = selectionFailureDeadLetterReason contract failure - assertReason expectedCode reason - renderDeadLetterReason reason `shouldNotSatisfy` Text.isInfixOf "secret" - - it "RouterSelection performs no target callback on conflict or overflow and dispatches exactly at the cap" $ \(_storeHandle, StoreRunner _runner) -> do - twoRecipientContract <- testSelectionContract EmptyAck FailureRetry 2 - oneRecipientContract <- testSelectionContract EmptyAck FailureRetry 1 - callbacks <- newIORef (0 :: Int) - let options = defaultRunCommandOptions & #beforeAppend .~ modifyIORef' callbacks (+ 1) - sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - targetA = PMCommand {target = stream "bounded-a", command = Add 1} - targetB = PMCommand {target = stream "bounded-b", command = Add 1} - targetBConflict = PMCommand {target = stream "bounded-b", command = Add 2} - Right conflict <- - _runner $ - runDeclarativeRouterOnce - options - (selectionRouter twoRecipientContract (pure (Right [targetB, targetBConflict, targetA]))) - sourceEvent - (RouteGroup "g1") - conflict `shouldBe` DeclarativeSelectionFailed (SelectionConflictingCommands (StreamName "bounded-b")) - readIORef callbacks `shouldReturn` 0 - Right overflow <- - _runner $ - runDeclarativeRouterOnce - options - (selectionRouter oneRecipientContract (pure (Right [targetB, targetA, targetB]))) - sourceEvent - (RouteGroup "g1") - overflow `shouldBe` DeclarativeSelectionFailed (SelectionRecipientOverflow (oneRecipientContract ^. #limit) 2) - readIORef callbacks `shouldReturn` 0 - Right atCap <- - _runner $ - runDeclarativeRouterOnce - options - (selectionRouter twoRecipientContract (pure (Right [targetB, targetA, targetB]))) - sourceEvent - (RouteGroup "g1") - atCap `shouldSatisfy` \case - DeclarativeSelectionDispatched (RouterResult results) -> length results == 2 && all isAppended results - _ -> False - readIORef callbacks `shouldReturn` 2 - - it "RouterSelection retains successful targets after a later target dispatch fails" $ \(_storeHandle, StoreRunner _runner) -> do - contract <- testSelectionContract EmptyAck FailureRetry 2 - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = - selectionRouter contract (pure (Right [PMCommand {target = stream "partial-a", command = Add 1}, PMCommand {target = stream "partial-b", command = Add 9}])) - & #targetEventStream - .~ rejectNineEventStream - Right result <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) - result `shouldSatisfy` \case - DeclarativeSelectionDispatched (RouterResult [first, second]) -> isAppended first && isFailed second - _ -> False - Right partialA <- _runner (Store.readStreamForward (StreamName "partial-a") (StreamVersion 0) 10) - Right partialB <- _runner (Store.readStreamForward (StreamName "partial-b") (StreamVersion 0) 10) - Vector.length partialA `shouldBe` 1 - Vector.length partialB `shouldBe` 0 - - it "RouterSelection preserves target-keyed stable union across result drift" $ \(_storeHandle, StoreRunner _runner) -> do - contract <- testSelectionContract EmptyAck FailureRetry 2 - attempts <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - selectAttempt _ = do - attempt <- liftIO (atomicModifyIORef' attempts (\value -> (value + 1, value))) - pure $ Right $ case attempt of - 0 -> commandsFor ["union-b", "union-a"] - _ -> commandsFor ["union-c", "union-a"] - commandsFor targetNames = [PMCommand {target = stream targetName, command = Add 1} | targetName <- targetNames] - router = (selectionRouter contract (pure (Right []))) {select = selectAttempt} - Right first <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) - Right second <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) - first `shouldSatisfy` \case - DeclarativeSelectionDispatched (RouterResult results) -> all isAppended results - _ -> False - second `shouldSatisfy` \case - DeclarativeSelectionDispatched (RouterResult [unionA, unionC]) -> isDuplicate unionA && isAppended unionC - _ -> False - for_ ["union-a", "union-b", "union-c"] $ \targetName -> do - Right events <- _runner (Store.readStreamForward (StreamName targetName) (StreamVersion 0) 10) - Vector.length events `shouldBe` 1 - - it "RouterSelection worker lowers the complete empty and failure policy matrices" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - message = (sourceEvent, RouteGroup "g1") - runCase emptySelectionPolicy failureSelectionPolicy selected = do - contract <- testSelectionContract emptySelectionPolicy failureSelectionPolicy 2 - decisions <- newIORef [] - Right () <- - _runner $ - runDeclarativeRouterWorker - defaultRunCommandOptions - (selectionRouter contract (pure selected)) - (inMemoryAdapter decisions [message]) - Just - readIORef decisions - runCase EmptyAck FailureRetry (Right []) `shouldReturn` [AckOk] - runCase EmptyRetry FailureRetry (Right []) `shouldReturn` [AckRetry (RetryDelay 5)] - emptyDeadLetter <- runCase EmptyDeadLetter FailureRetry (Right []) - emptyDeadLetter `shouldSatisfy` \case - [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.empty" - _ -> False - emptyHalt <- runCase EmptyHalt FailureRetry (Right []) - emptyHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False - runCase EmptyAck FailureRetry (Left (SelectionQueryFailed "private")) `shouldReturn` [AckRetry (RetryDelay 5)] - failureDeadLetter <- runCase EmptyAck FailureDeadLetter (Left (SelectionEvaluationFailed "private")) - failureDeadLetter `shouldSatisfy` \case - [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.evaluation_failed" - _ -> False - failureHalt <- runCase EmptyAck FailureHalt (Left (SelectionQueryFailed "private")) - failureHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False - - it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do - let sourceEventId = EventId sampleUuid - colonLeft = - deterministicRouterCommandId - "router:a" - "key" - sourceEventId - (StreamName "target") - 0 - colonRight = - deterministicRouterCommandId - "router" - "a:key" - sourceEventId - (StreamName "target") - 0 - unicodeLeft = - deterministicRouterCommandId - "router" - "key" - sourceEventId - (StreamName ("target-" <> Text.singleton '\x101')) - 0 - unicodeRight = - deterministicRouterCommandId - "router" - "key" - sourceEventId - (StreamName ("target-" <> Text.singleton '\x201')) - 0 - colonLeft `shouldNotBe` colonRight - unicodeLeft `shouldNotBe` unicodeRight - - it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "router-target-a") insertRouterTargetStmt - Tx.statement ("g1", "router-target-b") insertRouterTargetStmt - Tx.statement ("g1", "router-target-c") insertRouterTargetStmt - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - Right (RouterResult rs1) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - length rs1 `shouldBe` 3 - rs1 `shouldSatisfy` all isAppended - -- Data-dependence is load-bearing: an unseeded group resolves to no - -- targets, so the count tracks the read model, not a fixed list. - Right (RouterResult rsEmpty) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group") - length rsEmpty `shouldBe` 0 - -- Each resolved target stream received exactly one command. - Right targetA <- - _runner $ - Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 - Right targetB <- - _runner $ - Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 - Right targetC <- - _runner $ - Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 - Vector.length targetA `shouldBe` 1 - Vector.length targetB `shouldBe` 1 - Vector.length targetC `shouldBe` 1 - - it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "router-target-a") insertRouterTargetStmt - Tx.statement ("g1", "router-target-b") insertRouterTargetStmt - Tx.statement ("g1", "router-target-c") insertRouterTargetStmt - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - Right (RouterResult rs1) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - rs1 `shouldSatisfy` all isAppended - Right (RouterResult rs2) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - length rs2 `shouldBe` 3 - rs2 `shouldSatisfy` all isDuplicate - -- Replay added nothing: each target stream still holds exactly one event. - Right targetA <- - _runner $ - Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 - Right targetB <- - _runner $ - Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 - Right targetC <- - _runner $ - Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 - Vector.length targetA `shouldBe` 1 - Vector.length targetB `shouldBe` 1 - Vector.length targetC `shouldBe` 1 - - it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["swap-a"] - _ -> ["swap-b", "swap-a"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [swapB, swapA] -> isAppended swapB && isDuplicate swapA - _ -> False - Right swapAEvents <- - _runner $ - Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10 - Right swapBEvents <- - _runner $ - Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10 - Vector.length swapAEvents `shouldBe` 1 - Vector.length swapBEvents `shouldBe` 1 - - it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["growth-a", "growth-b"] - _ -> ["growth-a", "growth-c"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [growthA, growthC] -> isDuplicate growthA && isAppended growthC - _ -> False - Right growthAEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10 - Right growthBEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10 - Right growthCEvents <- - _runner $ - Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10 - Vector.length growthAEvents `shouldBe` 1 - Vector.length growthBEvents `shouldBe` 1 - Vector.length growthCEvents `shouldBe` 1 - - it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["order-a", "order-b"] - _ -> ["order-b", "order-a"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` all isDuplicate - Right orderAEvents <- - _runner $ - Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10 - Right orderBEvents <- - _runner $ - Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10 - Vector.length orderAEvents `shouldBe` 1 - Vector.length orderBEvents `shouldBe` 1 - - it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef $ \case - 0 -> ["drop-a", "drop-b"] - _ -> ["drop-b"] - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` \case - [dropB] -> isDuplicate dropB - _ -> False - -- Resolve is authoritative per attempt. Across redeliveries, the - -- dispatched set is the union of each attempt's resolved targets. - Right dropAEvents <- - _runner $ - Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10 - Right dropBEvents <- - _runner $ - Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10 - Vector.length dropAEvents `shouldBe` 1 - Vector.length dropBEvents `shouldBe` 1 - - it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do - attemptsRef <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - router = unstableRouter attemptsRef (const ["twin", "twin"]) - Right (RouterResult firstAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - firstAttempt `shouldSatisfy` all isAppended - Right twinEventsAfterFirstAttempt <- - _runner $ - Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 - Vector.length twinEventsAfterFirstAttempt `shouldBe` 2 - Right (RouterResult secondAttempt) <- - _runner $ - runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") - secondAttempt `shouldSatisfy` all isDuplicate - Right twinEventsAfterSecondAttempt <- - _runner $ - Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 - Vector.length twinEventsAfterSecondAttempt `shouldBe` 2 - - it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- _runner $ - Store.runTransaction $ do - Tx.statement ("g1", "worker-a") insertRouterTargetStmt - Tx.statement ("g1", "worker-b") insertRouterTargetStmt - Tx.statement ("g2", "worker-c") insertRouterTargetStmt - decisionsRef <- newIORef [] - let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = - [ (sourceEvent1, RouteGroup "g1"), - (sourceEvent2, RouteGroup "g2") - ] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions demoRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldBe` [AckOk, AckOk] - Right wa <- - _runner $ - Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10 - Right wb <- - _runner $ - Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10 - Right wc <- - _runner $ - Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10 - Vector.length wa `shouldBe` 1 - Vector.length wb `shouldBe` 1 - Vector.length wc `shouldBe` 1 - - it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - messages = [(sourceEvent, RouteGroup "g1")] - adapter = inMemoryAdapter decisionsRef messages - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions failingRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")] - workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter - Right () <- - _runner $ - runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just - readIORef decisionsRef `shouldReturn` [AckOk] - Right deadLetters <- _runner (listDispatchDeadLetters "failing-router") - case deadLetters of - [row] -> do - row ^. #dispatcherKind `shouldBe` DispatcherRouter - row ^. #correlationId `shouldBe` "g1" - row ^. #targetStreamName `shouldBe` StreamName "failing-target" - row ^. #errorClass `shouldBe` "command_rejected" - other -> expectationFailure ("expected one router dead letter, got " <> show other) - - it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt) - decisionsRef <- newIORef [] - attemptsRef <- newIORef (0 :: Int) - let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) - messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")] - adapter = inMemoryAdapter decisionsRef messages - flakyRouter :: - (IOE :> es, Store :> es, Error Store.StoreError :> es) => - Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es - flakyRouter = - Router - { name = "flaky-router", - key = \(RouteGroup g) -> g, - resolve = \(RouteGroup g) -> do - attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) - if attempt == 0 - then throwError (Store.ConnectionLost "injected") - else do - result <- runQuery Nothing routerTargetsReadModel g - pure $ case result of - Right targetIds -> - [ PMCommand {target = stream targetId, command = Add 1} - | targetId <- targetIds - ] - Left _ -> [], - targetEventStream = counterEventStream, - targetProjections = const [] - } - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions flakyRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckRetry {}, AckOk] -> True - _ -> False - - it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do - decisionsRef <- newIORef [] - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - messages = [(sourceEvent, RouteGroup "g1")] - adapter = inMemoryAdapter decisionsRef messages - failingResolveRouter :: - (Error Store.StoreError :> es) => - Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es - failingResolveRouter = - Router - { name = "failing-resolve-router", - key = \(RouteGroup g) -> g, - resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom"), - targetEventStream = counterEventStream, - targetProjections = const [] - } - Right () <- - _runner $ - runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just - decisions <- readIORef decisionsRef - decisions `shouldSatisfy` \case - [AckHalt (HaltFatal _)] -> True - _ -> False - - it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt) - insertCount <- newIORef (0 :: Int) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - targetStreamName = StreamName "router-duplicate-target" - commandId = - deterministicRouterCommandId - "demo-router" - "g1" - (sourceEvent ^. #eventId) - targetStreamName - 0 - insertConcurrentTarget = do - callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) - when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1) - options = - defaultRunCommandOptions - & #beforeAppend - .~ insertConcurrentTarget - & #retryBackoffMicros - .~ 0 - result <- - _runner $ - runRouterOnce options demoRouter sourceEvent (RouteGroup "g1") - case result of - Right (RouterResult [PMCommandDuplicate duplicateId]) -> - duplicateId `shouldBe` commandId - other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - Right () <- - _runner $ - Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt) - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0 - targetStreamName = StreamName "transition-target" - appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1) - result <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") - case result of - Right (RouterResult [PMCommandDuplicate duplicateId]) -> - duplicateId `shouldBe` legacyId - other -> expectationFailure ("expected transition duplicate, got " <> show other) - Right targetEvents <- - _runner $ - Store.readStreamForward targetStreamName (StreamVersion 0) 10 - Vector.length targetEvents `shouldBe` 1 - - it "bridges a pre-UTF-8 positional router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do - Right () <- - _runner $ - initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable - let correlationId = "g-\x4E2D\x6587" - targetStreamName = StreamName "transition-unicode-target" - sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) - legacyId = legacyDeterministicCommandId "demo-router" correlationId (sourceEvent ^. #eventId) 0 - Right () <- - _runner $ - Store.runTransaction (Tx.statement (correlationId, "transition-unicode-target") insertRouterTargetStmt) - appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 1) - Right (RouterResult results) <- - _runner $ - runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup correlationId) - Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 - (results, Vector.length targetEvents) - `shouldBe` ([PMCommandDuplicate legacyId], 1) - - it "bridges a pre-UTF-8 domain router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do - let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) - correlationId = "\x4E2D\x6587-9" - targetStreamName = StreamName ("domain-router-target:" <> correlationId <> ":0") - legacyId = legacyDeterministicCommandId "domain-router" correlationId (sourceEvent ^. #eventId) 0 - input = DomainDispatchInput correlationId [CoordinatorAccept 9] - appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 9) - Right (DomainRouterResult results) <- - _runner $ - runDomainRouterOnce defaultRunCommandOptions domainRouter sourceEvent input - Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 - (results, Vector.length targetEvents) - `shouldBe` ([DomainPMCommandDuplicate legacyId], 1) - - describe "Keiro.Timer foreground consumer" - $ around - ( \action -> - withFreshDatabase fixture $ \connection -> - Store.withStore (Store.defaultConnectionSettings connection) $ \firstStore -> - Store.withStore (Store.defaultConnectionSettings connection) $ \secondStore -> - action (firstStore, secondStore) - ) - $ do - it "preflights original work and invokes one callback for competing authorized resumes" $ \(firstStore, secondStore) -> do - let original = counterTimerRequest & #payload .~ object ["memorySpace" Aeson..= ("space-a" :: Text)] - tid = original ^. #timerId - owner = original ^. #processManagerName - reason = "deferred: interactive session required" - callbacks <- newIORef (0 :: Int) - let foreground store allowed available = do - Right _ <- Store.runStoreIO store recoverExpiredTimerResumes - Right inspected <- Store.runStoreIO store $ lookupTimerInspection tid - case inspected of - Just inspection - | inspection ^. #lastError == Just reason, - inspection ^. #timer . #payload == object ["memorySpace" Aeson..= ("space-a" :: Text)], - allowed, - available -> do - Right (Right claimed) <- Store.runStoreIO store $ claimDeadTimer (DeadTimerClaimRequest tid owner reason 3 60) - forM_ claimed $ \_ -> atomicModifyIORef' callbacks (\n -> (n + 1, ())) - pure claimed - _ -> pure Nothing - Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx original - Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid reason - Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt - -- Revocation after listing and repeated unavailable-session preflights. - Right (Right _) <- Store.runStoreIO firstStore $ findDeadTimers (DeadTimerFilter (Just owner) (ReasonExact reason)) (DeadTimerPageRequest 10 Nothing) - denied <- foreground firstStore False True - isNothing denied `shouldBe` True - forM_ [1 .. 3 :: Int] $ \_ -> do - unavailable <- foreground firstStore True False - isNothing unavailable `shouldBe` True - Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before - (a, b) <- timerRaceIO (foreground firstStore True True) (foreground secondStore True True) - length (catMaybes [a, b]) `shouldBe` 1 - readIORef callbacks `shouldReturn` 1 - -- Crash, deterministic expiry, and recovery keep interactive work parked. - Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx - Store.runStoreIO secondStore recoverExpiredTimerResumes `shouldReturn` Right 1 - Store.runStoreIO firstStore (runTimerWorker Nothing dueTimerTime (\_ -> error "interactive work dispatched in background")) `shouldReturn` Right Nothing - unavailable <- foreground firstStore True False - isNothing unavailable `shouldBe` True - Just next <- foreground secondStore True True - resumeClaimTimer next ^. #timerId `shouldBe` tid - resumeClaimTimer next ^. #attempts `shouldBe` 2 - -- A transient post-claim failure consumes the attempt and retains reason. - Store.runStoreIO secondStore (parkTimerResume next) `shouldReturn` Right True - Right (Just parked) <- Store.runStoreIO firstStore $ lookupTimerInspection tid - parked ^. #lastError `shouldBe` Just reason - parked ^. #timer . #attempts `shouldBe` 2 - -- Malformed work and ordinary dead letters are application refusals. - Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET payload = '{}'::jsonb" - malformed <- foreground firstStore True True - isNothing malformed `shouldBe` True - Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET last_error = 'ordinary dead letter'" - ordinary <- foreground firstStore True True - isNothing ordinary `shouldBe` True - readIORef callbacks `shouldReturn` 2 - - it "orders renewal and completion against recovery on independent stores" $ \(firstStore, secondStore) -> do - let tid = counterTimerRequest ^. #timerId - request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60 - Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx counterTimerRequest - Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid "deferred" - Right (Right (Just claim)) <- Store.runStoreIO firstStore $ claimDeadTimer request - (renewed, recovered) <- - timerRaceIO - (Store.runStoreIO firstStore $ renewTimerResume claim 60) - (Store.runStoreIO secondStore recoverExpiredTimerResumes) - renewed `shouldBe` Right (Right True) - recovered `shouldBe` Right 0 - Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx - (expiredRenewal, expiredRecovery) <- - timerRaceIO - (Store.runStoreIO firstStore $ renewTimerResume claim 60) - (Store.runStoreIO secondStore recoverExpiredTimerResumes) - expiredRenewal `shouldBe` Right (Right False) - expiredRecovery `shouldBe` Right 1 - Right (Right (Just replacement)) <- Store.runStoreIO firstStore $ claimDeadTimer request - Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt - forM_ [parkTimerResume claim, cancelTimerResume claim, completeTimerResume claim (EventId sampleUuid2)] $ \operation -> - Store.runStoreIO firstStore operation `shouldReturn` Right False - Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before - Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx - (expiredCompletion, completionRecovery) <- - timerRaceIO - (Store.runStoreIO firstStore $ completeTimerResume replacement (EventId sampleUuid2)) - (Store.runStoreIO secondStore recoverExpiredTimerResumes) - expiredCompletion `shouldBe` Right False - completionRecovery `shouldBe` Right 1 - Right (Right (Just finalClaim)) <- Store.runStoreIO firstStore $ claimDeadTimer request - (completed, noRecovery) <- - timerRaceIO - (Store.runStoreIO firstStore $ completeTimerResume finalClaim (EventId sampleUuid2)) - (Store.runStoreIO secondStore recoverExpiredTimerResumes) - completed `shouldBe` Right True - noRecovery `shouldBe` Right 0 - - describe "Keiro.Timer" $ around (withFreshStore fixture) $ do - it "guards dead resume ownership and retains attempts when parked" $ \storeHandle -> do - let tid = counterTimerRequest ^. #timerId - request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 2 60 - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" - Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request - resumeClaimTimer claim ^. #attempts `shouldBe` 1 - Store.runStoreIO storeHandle (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing - Store.runStoreIO storeHandle (markTimerFired tid (EventId sampleUuid2)) `shouldReturn` Right False - Store.runStoreIO storeHandle (cancelTimer tid) `shouldReturn` Right False - Store.runStoreIO storeHandle (deadLetterTimer tid "wrong") `shouldReturn` Right False - Store.runStoreIO storeHandle (requeueStuckTimer tid) `shouldReturn` Right False - Store.runStoreIO storeHandle (requeueStuckTimers 0 (resumeClaimLeaseUntil claim)) `shouldReturn` Right 0 - Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right True) - Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right True - Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request - resumeClaimTimer replacement ^. #attempts `shouldBe` 2 - Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right False - Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right False - Store.runStoreIO storeHandle (cancelTimerResume claim) `shouldReturn` Right False - Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right False) - Store.runStoreIO storeHandle (parkTimerResume replacement) `shouldReturn` Right True - Right (Right refused) <- Store.runStoreIO storeHandle $ claimDeadTimer request - isNothing refused `shouldBe` True - Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid - observed ^. #lastError `shouldBe` Just "deferred" - observed ^. #timer . #attempts `shouldBe` 2 - - it "refuses every ineligible claim without changing any persisted column" $ \storeHandle -> do - let tid = counterTimerRequest ^. #timerId - request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 1 60 - snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt - refused req = do - before <- snapshot - Right (Right result) <- Store.runStoreIO storeHandle $ claimDeadTimer req - isNothing result `shouldBe` True - snapshot `shouldReturn` before - refused request - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest - refused request - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - refused request - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" - refused (request & #processManagerName .~ "COUNTER") - refused (request & #expectedReason .~ "Deferred") - refused (request & #maxAttempts .~ 0) - refused request -- ordinary claim already consumed the ceiling - before <- snapshot - Right (Left badMax) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ (-1)) - badMax `shouldBe` InvalidTimerResumeMaxAttempts (-1) - forM_ [0, -1, maxBound] $ \seconds -> do - Right (Left badLease) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #leaseSeconds .~ seconds) - badLease `shouldBe` InvalidTimerResumeLeaseSeconds seconds - snapshot `shouldReturn` before - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement (case tid of TimerId uuid -> uuid) legacyDeadTimerReasonStmt - refused (request & #maxAttempts .~ 2) - - it "claims literal empty and Unicode reasons and preserves original work" $ \storeHandle -> do - forM_ (zip [1 ..] ["", "延期: café 日本語 🌱", "a%_\\'雪"]) $ \(n, reason) -> do - let original = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n) - tid = original ^. #timerId - request = DeadTimerClaimRequest tid (original ^. #processManagerName) reason 1 60 - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx original - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid reason - Right (Just before) <- Store.runStoreIO storeHandle $ lookupTimer tid - Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request - resumeClaimTimer claim `shouldBe` (before & #status .~ Firing & #attempts .~ 1) - Right (Right repeated) <- Store.runStoreIO storeHandle $ claimDeadTimer request - isNothing repeated `shouldBe` True - Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right True - Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid - inspection ^. #lastError `shouldBe` Just reason - inspection ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2) - Right (Right terminal) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ 2) - isNothing terminal `shouldBe` True - - it "expires without revival and re-parks independently of ordinary recovery" $ \storeHandle -> do - let tid = counterTimerRequest ^. #timerId - request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60 - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" - Right (Right (Just old)) <- Store.runStoreIO storeHandle $ claimDeadTimer request - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction expireTimerResumesTx - Right before <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt - Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False) - Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False - Store.runStoreIO storeHandle (parkTimerResume old) `shouldReturn` Right False - Store.runStoreIO storeHandle (cancelTimerResume old) `shouldReturn` Right False - Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before - let options = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing - Store.runStoreIO storeHandle (runTimerWorkerWith Nothing options dueTimerTime (\_ -> error "foreground work reached background")) `shouldReturn` Right Nothing - Store.runStoreIO storeHandle recoverExpiredTimerResumes `shouldReturn` Right 0 - Right (Just parked) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid - parked ^. #timer . #status `shouldBe` Dead - parked ^. #timer . #attempts `shouldBe` 1 - parked ^. #lastError `shouldBe` Just "deferred" - Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request - Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False - Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False) - Store.runStoreIO storeHandle (cancelTimerResume replacement) `shouldReturn` Right True - Right (Right cancelled) <- Store.runStoreIO storeHandle $ claimDeadTimer request - isNothing cancelled `shouldBe` True - - it "inspects absent timers and preserves legacy metadata through every lifecycle" $ \storeHandle -> do - let tid = counterTimerRequest ^. #timerId - inspect reason = do - Right old <- Store.runStoreIO storeHandle $ lookupTimer tid - Right observed <- Store.runStoreIO storeHandle $ lookupTimerInspection tid - fmap (^. #timer) observed `shouldBe` old - fmap (^. #lastError) observed `shouldBe` Just reason - Store.runStoreIO storeHandle (lookupTimerInspection tid) `shouldReturn` Right Nothing - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest - inspect Nothing - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - inspect Nothing - Right True <- Store.runStoreIO storeHandle $ markTimerFired tid (EventId sampleUuid2) - inspect Nothing - Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid - observed ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2) - observed ^. #timer . #attempts `shouldBe` 1 - - it "preserves empty, populated, and Unicode dead reasons verbatim" $ \storeHandle -> do - forM_ (zip [1 ..] ["", " retry exhausted ", "延期: café 日本語 🌱"]) $ \(n, reason) -> do - let request = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n) - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) reason - Right old <- Store.runStoreIO storeHandle $ lookupTimer (request ^. #timerId) - Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection (request ^. #timerId) - Just (observed ^. #timer) `shouldBe` old - observed ^. #lastError `shouldBe` Just reason - - it "filters dead timers by exact owner and literal reason, preserving NULL" $ \storeHandle -> do - let fixtures = - [ (1, "A", Just "deferred: one"), - (2, "A", Just "deferred: 二"), - (3, "B", Just "deferred: three"), - (4, "A", Just "ordinary"), - (5, "A", Nothing), - (6, "A", Just ""), - (7, "A", Just "a%_\\'雪 tail"), - (8, "A", Just "aXX雪 tail"), - (9, "a", Just "Deferred: one") - ] - tid n = TimerId (UUID.fromWords 0 0 0 n) - check owner reason expected = do - Right (Right page) <- - Store.runStoreIO storeHandle $ - findDeadTimers (DeadTimerFilter owner reason) (DeadTimerPageRequest 100 Nothing) - fmap (^. #timer . #timerId) (page ^. #timers) `shouldBe` fmap tid expected - page ^. #nextAfterTimerId `shouldBe` Nothing - forM_ fixtures $ \(n, owner, reason) -> do - let request = counterTimerRequest & #timerId .~ tid n & #processManagerName .~ owner - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (tid n) (fromMaybe "legacy" reason) - when (isNothing reason) $ do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement (UUID.fromWords 0 0 0 n) legacyDeadTimerReasonStmt - Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid n) - inspection ^. #lastError `shouldBe` Nothing - -- Include every non-dead lifecycle in the same manager/reason search space. - forM_ [10 .. 13] $ \n -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx (counterTimerRequest & #timerId .~ tid n & #processManagerName .~ "A") - pure () - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - Right True <- Store.runStoreIO storeHandle $ markTimerFired (tid 10) (EventId sampleUuid2) - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - Right True <- Store.runStoreIO storeHandle $ cancelTimer (tid 12) - Right (Just cancelled) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid 12) - cancelled ^. #timer . #status `shouldBe` Timer.Cancelled - check Nothing AnyTimerReason [1 .. 9] - check (Just "A") (ReasonPrefix "deferred:") [1, 2] - check Nothing (ReasonPrefix "deferred:") [1, 2, 3] - check (Just "a") AnyTimerReason [9] - check Nothing ReasonAbsent [5] - check Nothing (ReasonExact "") [6] - check Nothing (ReasonPrefix "") [1, 2, 3, 4, 6, 7, 8, 9] - check Nothing (ReasonExact "deferred: 二") [2] - check Nothing (ReasonPrefix "a%_\\'雪") [7] - check Nothing (ReasonExact "a%_\\'雪 tail") [7] - check Nothing (ReasonExact "DEFERRED: one") [] - check (Just "A' OR TRUE --") AnyTimerReason [] - - it "bounds pages, traverses UUID order, and leaves every stored column unchanged" $ \storeHandle -> do - forM_ [1 .. 101] $ \n -> do - let request = plainTimerRequest n - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) "deferred" - pure () - let snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt - readPage size cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest size cursor) - storedBefore <- snapshot - forM_ [-1, 0, 101, maxBound] $ \size -> - readPage size Nothing `shouldReturn` Right (Left (InvalidDeadTimerPageSize size)) - Right (Right first) <- readPage 100 Nothing - length (first ^. #timers) `shouldBe` 100 - first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 100 ^. #timerId) - readPage 100 Nothing `shouldReturn` Right (Right first) - Right (Right finalPage) <- readPage 100 (first ^. #nextAfterTimerId) - fmap (^. #timer . #timerId) (finalPage ^. #timers) `shouldBe` [plainTimerRequest 101 ^. #timerId] - finalPage ^. #nextAfterTimerId `shouldBe` Nothing - readPage 1 (Just (plainTimerRequest 101 ^. #timerId)) `shouldReturn` Right (Right (DeadTimerPage [] Nothing)) - let walk cursor = do - Right (Right page) <- readPage 1 cursor - let ids = fmap (^. #timer . #timerId) (page ^. #timers) - case page ^. #nextAfterTimerId of - Nothing -> pure ids - next -> (ids <>) <$> walk next - walk Nothing `shouldReturn` fmap ((^. #timerId) . plainTimerRequest) [1 .. 101] - Right (Just _) <- Store.runStoreIO storeHandle $ lookupTimerInspection (plainTimerRequest 1 ^. #timerId) - snapshot `shouldReturn` storedBefore - Store.runStoreIO storeHandle (runTimerWorker Nothing dueTimerTime (\_ -> pure (Just (EventId sampleUuid2)))) - `shouldReturn` Right Nothing - snapshot `shouldReturn` storedBefore - - it "continues after a deleted cursor and observes new eligibility only above it" $ \storeHandle -> do - let add n = do - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n) - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) "deferred" - pure () - readPage cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest 1 cursor) - mapM_ add [20, 40, 60] - Right (Right first) <- readPage Nothing - first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 20 ^. #timerId) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql - "DELETE FROM keiro.keiro_timers WHERE correlation_id = 'drain-20'; UPDATE keiro.keiro_timers SET status = 'cancelled' WHERE correlation_id = 'drain-40'" - mapM_ add [10, 30] - Right (Right second) <- readPage (first ^. #nextAfterTimerId) - fmap (^. #timer . #timerId) (second ^. #timers) `shouldBe` [plainTimerRequest 30 ^. #timerId] - Right (Right third) <- readPage (second ^. #nextAfterTimerId) - fmap (^. #timer . #timerId) (third ^. #timers) `shouldBe` [plainTimerRequest 60 ^. #timerId] - third ^. #nextAfterTimerId `shouldBe` Nothing - - it "renders authorized original work beyond empty pages and rechecks revoked permissions" $ \storeHandle -> do - let reason = "kioku:deferred:interactive-unavailable feature=summary details=保持" - deadFilter = DeadTimerFilter (Just "drain-pm") (ReasonPrefix "kioku:deferred:interactive-unavailable feature=") - entries = - [ (1, object ["space" Aeson..= ("hidden" :: Text), "work" Aeson..= ("secret" :: Text)]), - (2, object ["invalid" Aeson..= ("never render" :: Text)]), - (3, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("original work" :: Text)]), - (4, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("revoked work" :: Text)]) - ] - forM_ entries $ \(n, payload) -> do - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n & #payload .~ payload) - Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) reason - pure () - permissions <- newIORef (Set.singleton ("allowed" :: Text)) - let renderPage cursor = do - Right (Right page) <- Store.runStoreIO storeHandle $ findDeadTimers deadFilter (DeadTimerPageRequest 1 cursor) - fresh <- readIORef permissions - rendered <- fmap catMaybes $ forM (page ^. #timers) $ \listed -> do - Right inspected <- Store.runStoreIO storeHandle $ lookupTimerInspection (listed ^. #timer . #timerId) - pure $ do - inspection <- inspected - (space, work) <- - either (const Nothing) Just $ - parseEither (withObject "work" (\o -> (,) <$> o .: "space" <*> o .: "work")) (inspection ^. #timer . #payload) - if Set.member space fresh then Just (work :: Text, inspection ^. #lastError) else Nothing - pure (rendered, page ^. #nextAfterTimerId) - (hidden, next1) <- renderPage Nothing - hidden `shouldBe` [] - next1 `shouldSatisfy` isJust - (malformed, next2) <- renderPage next1 - malformed `shouldBe` [] - next2 `shouldSatisfy` isJust - (allowed, next3) <- renderPage next2 - allowed `shouldBe` [("original work", Just reason)] - writeIORef permissions Set.empty - renderPage next3 `shouldReturn` ([], Nothing) - - it "validates worker options before startup" $ \_storeHandle -> do - shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions) - mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1)) - `shouldBeLeft` InvalidTimerMaxAttempts (-1) - mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0) - `shouldBeLeft` InvalidTimerRequeueStuckAfter 0 - - it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - let firedEventId = EventId sampleUuid2 - workerResult <- Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime $ \_ -> do - fired <- - runCommand - (defaultRunCommandOptions & #eventIds .~ [firedEventId]) - counterEventStream - (stream "timer-target") - (Add 11) - case fired of - Right _ -> pure (Just firedEventId) - Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing - case workerResult of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected fired timer, got " <> show other) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - Right targetEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] - - it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - let firedEventId = EventId sampleUuid2 - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId)) - case workerResult of - Right (Just _) -> pure () - other -> expectationFailure ("expected a fired timer, got " <> show other) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - -- One scheduled+due row at the start of the pass: backlog gauge holds 1. - lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1) - -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0. - lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0) - -- The claimed timer was due exactly at 'now' and is on its first attempt: - -- one fire.lag observation of 0 ms and one attempts observation of 1. - [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)] - [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)] - - it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - -- Strand it in Firing by claiming without firing. - claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - case claimed of - Right (Just timer) -> timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a claimed timer, got " <> show other) - Right lookedUp <- - Store.runStoreIO storeHandle $ - lookupTimer (counterTimerRequest ^. #timerId) - fmap (^. #status) lookedUp `shouldBe` Just Firing - -- It surfaces as stuck under the permissive filter. - Right stuck <- - Store.runStoreIO storeHandle $ - findStuckTimers dueTimerTime anyStuckTimer - fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId] - -- A bound it does not meet (only one attempt) excludes it. - Right unmatched <- - Store.runStoreIO storeHandle $ - findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5)) - unmatched `shouldBe` [] - -- Requeue is idempotent: True the first time, False once it is scheduled. - requeued <- - Store.runStoreIO storeHandle $ - requeueStuckTimer (counterTimerRequest ^. #timerId) - requeued `shouldBe` Right True - requeuedAgain <- - Store.runStoreIO storeHandle $ - requeueStuckTimer (counterTimerRequest ^. #timerId) - requeuedAgain `shouldBe` Right False - -- The ordinary loop re-claims and fires it exactly once. - let firedEventId = EventId sampleUuid2 - workerResult <- Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime $ \_ -> do - fired <- - runCommand - (defaultRunCommandOptions & #eventIds .~ [firedEventId]) - counterEventStream - (stream "timer-target") - (Add 7) - case fired of - Right _ -> pure (Just firedEventId) - Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing - case workerResult of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected re-fired timer, got " <> show other) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - Right targetEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 - fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] - - it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - claimed ^. #status `shouldBe` Firing - realNow <- getCurrentTime - firedRef <- newIORef [] - let futureNow = addUTCTime 400 realNow - firedEventId = EventId sampleUuid2 - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing futureNow $ \timer -> do - liftIO (modifyIORef' firedRef (<> [timer ^. #timerId])) - pure (Just firedEventId) - case workerResult of - Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId - other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other) - firedTimers <- readIORef firedRef - firedTimers `shouldBe` [counterTimerRequest ^. #timerId] - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("fired", Nothing) - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - - it "does not requeue a fresh firing row" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - realNow <- getCurrentTime - firedRef <- newIORef False - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing realNow $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just (EventId sampleUuid2)) - workerResult `shouldBe` Right Nothing - didFire <- readIORef firedRef - didFire `shouldBe` False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("firing", Nothing) - - it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - realNow <- getCurrentTime - firedRef <- newIORef False - let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just (EventId sampleUuid2)) - workerResult `shouldBe` Right Nothing - didFire <- readIORef firedRef - didFire `shouldBe` False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("firing", Nothing) - - it "does not claim a cancelled timer" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - cancelled <- - Store.runStoreIO storeHandle $ - cancelTimer (counterTimerRequest ^. #timerId) - cancelled `shouldBe` Right True - claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - claimed `shouldBe` Right Nothing - cancelledAgain <- - Store.runStoreIO storeHandle $ - cancelTimer (counterTimerRequest ^. #timerId) - cancelledAgain `shouldBe` Right False - - it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - firedRef <- newIORef False - let firedEventId = EventId sampleUuid2 - -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the - -- worker dead-letters instead of firing. - result <- Store.runStoreIO storeHandle $ - runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do - liftIO (writeIORef firedRef True) - pure (Just firedEventId) - case result of - Right (Just timer) -> - timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a claimed timer, got " <> show other) - -- The fire action never ran. - didFire <- readIORef firedRef - didFire `shouldBe` False - -- The row landed in 'dead' with the expected reason in last_error. - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0") - -- A dead row is never re-claimed. - secondWorkerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) - secondWorkerResult `shouldBe` Right Nothing - - it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - deadened <- - Store.runStoreIO storeHandle $ - deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter" - deadened `shouldBe` Right True - marked <- - Store.runStoreIO storeHandle $ - markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2) - marked `shouldBe` Right False - Right statusRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement sampleUuid timerStatusAndErrorStmt - statusRow `shouldBe` Just ("dead", Just "operator dead-letter") - - it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - scheduleTimerTx counterTimerRequest - -- Strand it in Firing by claiming without firing (a crashed worker). - Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime - -- A later pass finds nothing scheduled and due, but sees the stranded row. - workerResult <- - Store.runStoreIO storeHandle $ - runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing) - workerResult `shouldBe` Right Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- The one firing row is counted as stuck. - lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1) - -- It is not 'scheduled', so it does not show up as backlog. - lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0) - - describe "Keiro.Outbox.Kafka" $ do - it "converts an outbox row to a Kafka producer record" $ do - let envelope = sampleIntegrationEnvelope - row = sampleOutboxRow envelope - record = OutboxKafka.outboxRowToKafkaRecord row - record ^. #topic `shouldBe` envelope ^. #destination - record ^. #key `shouldBe` Just "order-123" - record ^. #payload `shouldBe` envelope ^. #payloadBytes - -- Headers include identity fields and content type. - let headers = record ^. #headers - messageIdHeader = Prelude.lookup "keiro-message-id" headers - messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa" - - it "drops the partition key when the envelope has no key" $ do - let envelope = sampleIntegrationEnvelope & #key .~ Nothing - record = OutboxKafka.integrationEventToKafkaRecord envelope - record ^. #key `shouldBe` Nothing - - describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do - it "validates terminal publication rejection data at its public boundary" $ \_storeHandle -> do - let validCode64 = "a" <> Text.replicate 63 "z" - validDetail1024 = Text.replicate 1024 "x" - validUtf8Detail = Text.replicate 512 "é" - valid <- shouldBeRight (mkPublishRejection validCode64 (Just validDetail1024)) - publishRejectionCode valid `shouldBe` validCode64 - publishRejectionDetail valid `shouldBe` Just validDetail1024 - shouldBeRight_ (mkPublishRejection "authorization.denied_v2" Nothing) - shouldBeRight_ (mkPublishRejection "invalid-destination" (Just validUtf8Detail)) - mkPublishRejection "" Nothing - `shouldBeLeft` InvalidPublishRejectionCode "" - mkPublishRejection "Uppercase" Nothing - `shouldBeLeft` InvalidPublishRejectionCode "Uppercase" - mkPublishRejection "1leading-digit" Nothing - `shouldBeLeft` InvalidPublishRejectionCode "1leading-digit" - mkPublishRejection "contains/slash" Nothing - `shouldBeLeft` InvalidPublishRejectionCode "contains/slash" - mkPublishRejection ("a" <> Text.replicate 64 "z") Nothing - `shouldBeLeft` InvalidPublishRejectionCode ("a" <> Text.replicate 64 "z") - mkPublishRejection "invalid-destination" (Just "") - `shouldBeLeft` PublishRejectionDetailEmpty - mkPublishRejection "invalid-destination" (Just (Text.replicate 513 "é")) - `shouldBeLeft` PublishRejectionDetailTooLong 1026 - - it "validates publisher options before startup" $ \_storeHandle -> do - shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions) - mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0) - `shouldBeLeft` InvalidOutboxBatchSize 0 - mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0) - `shouldBeLeft` InvalidOutboxMaxAttempts 0 - mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0) - `shouldBeLeft` InvalidOutboxPublishingTimeout 0 - mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1)) - `shouldBeLeft` InvalidConstantBackoff (-1) - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 0, - maxDelay = 1, - multiplier = 2 - } - ) - `shouldBeLeft` InvalidExponentialBackoffInitial 0 - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 1, - maxDelay = 10, - multiplier = 0.5 - } - ) - `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5 - mkOutboxPublishOptions - ( defaultPublishOptions - & #backoff - .~ ExponentialBackoff - ExponentialBackoffOptions - { initial = 5, - maxDelay = 4, - multiplier = 2 - } - ) - `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4 - - it "enqueues and looks up an outbox row" $ \storeHandle -> do - let envelope = sampleIntegrationEnvelope - oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid envelope) - lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid) - case lookedUp of - Right (Just row) -> do - row ^. #outboxId `shouldBe` oid - row ^. #status `shouldBe` OutboxPending - row ^. #attemptCount `shouldBe` 0 - row ^. #event . #messageId `shouldBe` envelope ^. #messageId - row ^. #event . #destination `shouldBe` envelope ^. #destination - row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes - other -> expectationFailure ("expected enqueued row, got " <> show other) - - it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - case rows of - [row] -> do - row ^. #outboxId `shouldBe` oid - row ^. #status `shouldBe` OutboxPublishing - row ^. #attemptCount `shouldBe` 1 - other -> expectationFailure ("expected one claimed row, got " <> show other) - - it "claims contiguous per-key runs in one pass" $ \storeHandle -> do - let keyedRows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A"), - (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A"), - (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A"), - (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A"), - (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A"), - (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B"), - (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B"), - (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) keyedRows - now <- getCurrentTime - Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows - fmap (^. #attemptCount) rows `shouldBe` replicate 8 1 - - it "does not let a backoff head starve other keys" $ \storeHandle -> do - let a1Id = outboxIdFromOrdinal 1 - a2Id = outboxIdFromOrdinal 2 - b1Id = outboxIdFromOrdinal 3 - b2Id = outboxIdFromOrdinal 4 - rows = - [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A"), - (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A"), - (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B"), - (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B") - ] - failA1 row - | row ^. #outboxId == a1Id = pure (PublishFailed "wait") - | otherwise = pure PublishSucceeded - opts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 3600 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing) - failedPass ^. #retried `shouldBe` 1 - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id] - Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row ^. #status `shouldBe` OutboxPending - - it "claims contiguous per-source runs in one pass" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A"), - (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B"), - (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A"), - (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now) - fmap (^. #outboxId) claimed `shouldBe` fmap fst rows - - it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing), - (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A"), - (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing), - (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` fmap fst rows - - it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A"), - (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A"), - (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A") - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - now <- getCurrentTime - Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows - Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - secondClaim `shouldBe` [] - - it "marks a claimed row as sent with published_at set" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - row ^. #publishedAt `shouldSatisfy` isJust - row ^. #lastError `shouldBe` Nothing - - it "finalizes rejection exactly once with durable typed audit data" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "sink policy refused this message")) - replacement <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - firstClaimAt <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 firstClaimAt) - Right (Just OutboxFailed) <- - Store.runStoreIO storeHandle $ - Store.runTransaction (markOutboxFailedTx oid "transient predecessor" 5 0 firstClaimAt) - secondClaimAt <- getCurrentTime - Right [claimed] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 secondClaimAt) - rejectedAt <- getCurrentTime - Right True <- - Store.runStoreIO storeHandle $ - Store.runTransaction (markOutboxRejectedTx oid rejection rejectedAt) - Right False <- - Store.runStoreIO storeHandle $ - Store.runTransaction (markOutboxRejectedTx oid replacement (addUTCTime 60 rejectedAt)) - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxRejected - row ^. #attemptCount `shouldBe` 2 - row ^. #nextAttemptAt `shouldBe` claimed ^. #nextAttemptAt - row ^. #lastError `shouldBe` Nothing - row ^. #publishedAt `shouldBe` Nothing - row ^. #rejectedAt `shouldBe` Just rejectedAt - row ^. #rejection `shouldBe` Just rejection - - it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) - Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) - stranded ^. #status `shouldBe` OutboxPublishing - publishedRef <- newIORef (0 :: Int) - let publish _ = do - liftIO (modifyIORef' publishedRef (+ 1)) - pure PublishSucceeded - Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - noPublish ^. #claimed `shouldBe` 0 - Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) - stillStranded ^. #status `shouldBe` OutboxPublishing - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 1 - maintenance ^. #deadLettered `shouldBe` 0 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #published `shouldBe` 1 - published <- readIORef publishedRef - published `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - - it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do - let firstId = OutboxId outboxUuid1 - secondId = OutboxId outboxUuid2 - first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key" - second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx firstId first) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx secondId second) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now) - claimedFirst ^. #outboxId `shouldBe` firstId - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow) - publishedRef <- newIORef [] - let publish row = do - liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId])) - pure PublishSucceeded - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 1 - Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - firstPass ^. #published `shouldBe` 2 - Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - secondPass ^. #published `shouldBe` 0 - published <- readIORef publishedRef - published `shouldBe` [firstId, secondId] - Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId) - secondRow ^. #status `shouldBe` OutboxSent - - it "does not reclaim a recently claimed row" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - publishedRef <- newIORef (0 :: Int) - let publish _ = do - liftIO (modifyIORef' publishedRef (+ 1)) - pure PublishSucceeded - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 0 - published <- readIORef publishedRef - published `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxPublishing - - it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do - let throwId = OutboxId outboxUuid1 - okId = OutboxId outboxUuid2 - throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key" - okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - let publish row - | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded")) - | otherwise = pure PublishSucceeded - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #retried `shouldBe` 2 - summary ^. #published `shouldBe` 0 - Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId) - throwRow ^. #status `shouldBe` OutboxFailed - throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") - Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) - okRow ^. #status `shouldBe` OutboxFailed - okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") - - it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - opts = defaultMaintenanceOptions & #maxAttempts .~ 1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - let pastNow = addUTCTime (-3600) now - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) - Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing) - summary ^. #requeued `shouldBe` 0 - summary ^. #deadLettered `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - - it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - let publish _ = pure (PublishFailed "boom") - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - now <- getCurrentTime - Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now) - marked `shouldBe` False - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - - it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do - let okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - okEvent = sampleIntegrationEnvelope - failEvent = - sampleIntegrationEnvelope - & #messageId - .~ "msg-fail-1" - & #key - .~ Just "order-789" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | otherwise = pure (PublishFailed "broker unreachable") - Right summary <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 2 - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - summary ^. #dead `shouldBe` 0 - Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) - okRow ^. #status `shouldBe` OutboxSent - Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId) - failRow ^. #status `shouldBe` OutboxFailed - failRow ^. #lastError `shouldBe` Just "broker unreachable" - - it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do - let rows = - [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key") - | i <- [1 .. 10 :: Int] - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - invocationRef <- newIORef (0 :: Int) - let publish claimed = do - liftIO (modifyIORef' invocationRef (+ 1)) - pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed] - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 10 - summary ^. #published `shouldBe` 10 - invocations <- readIORef invocationRef - invocations `shouldBe` 1 - for_ (fmap fst rows) $ \oid -> do - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - - it "finalizes a mid-run rejection and continues the same-key suffix" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - rows = - [ (row1Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-1" & #key .~ Just "reject-run-key"), - (row2Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-2" & #key .~ Just "reject-run-key"), - (row3Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-3" & #key .~ Just "reject-run-key") - ] - rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "the configured sink cannot accept this event type")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - let publish claimed = - pure - [ ( row ^. #outboxId, - if row ^. #outboxId == row2Id - then PublishRejected rejection - else PublishSucceeded - ) - | row <- claimed - ] - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #claimed `shouldBe` 3 - summary ^. #published `shouldBe` 2 - summary ^. #rejected `shouldBe` 1 - summary ^. #retried `shouldBe` 0 - Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) - Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) - Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - row1 ^. #status `shouldBe` OutboxSent - row2 ^. #status `shouldBe` OutboxRejected - row2 ^. #rejection `shouldBe` Just rejection - row3 ^. #status `shouldBe` OutboxSent - - it "redelivers callbacks after a pre-commit finalization failure" $ \storeHandle -> do - let sentId = outboxIdFromOrdinal 1 - rejectedId = outboxIdFromOrdinal 2 - rows = - [ (sentId, sampleIntegrationEnvelope & #messageId .~ "precommit-sent" & #key .~ Just "precommit-key"), - (rejectedId, sampleIntegrationEnvelope & #messageId .~ "precommit-rejected" & #key .~ Just "precommit-key") - ] - rejection <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - callbackInvocations <- newIORef [] - let publish claimed = do - liftIO (modifyIORef' callbackInvocations (fmap (^. #outboxId) claimed :)) - pure - [ (row ^. #outboxId, if row ^. #outboxId == rejectedId then PublishRejected rejection else PublishSucceeded) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql - "ALTER TABLE keiro.keiro_outbox ADD CONSTRAINT keiro_outbox_test_rejection_block CHECK (status <> 'rejected')" - first <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - first `shouldSatisfy` \case - Left _ -> True - Right _ -> False - Right (Just stillPublishingSent) <- Store.runStoreIO storeHandle (lookupOutbox sentId) - Right (Just stillPublishingRejected) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId) - stillPublishingSent ^. #status `shouldBe` OutboxPublishing - stillPublishingRejected ^. #status `shouldBe` OutboxPublishing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_outbox DROP CONSTRAINT keiro_outbox_test_rejection_block" - now <- getCurrentTime - let strandedAt = addUTCTime (-3600) now - maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1 - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt sentId strandedAt) - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt rejectedId strandedAt) - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass maintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 2 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #rejected `shouldBe` 1 - Right (Just sentRow) <- Store.runStoreIO storeHandle (lookupOutbox sentId) - Right (Just rejectedRow) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId) - sentRow ^. #status `shouldBe` OutboxSent - rejectedRow ^. #status `shouldBe` OutboxRejected - invocations <- readIORef callbackInvocations - invocations `shouldBe` replicate 2 [sentId, rejectedId] - - it "treats rejection as terminal for per-source ordering" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - sourceEvent oid messageId = - (oid, sampleIntegrationEnvelope & #messageId .~ messageId & #source .~ "reject-source" & #key .~ Nothing) - rows = - [ sourceEvent row1Id "reject-source-1", - sourceEvent row2Id "reject-source-2", - sourceEvent row3Id "reject-source-3" - ] - rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - let publish claimed = - pure - [ (row ^. #outboxId, if row ^. #outboxId == row2Id then PublishRejected rejection else PublishSucceeded) - | row <- claimed - ] - opts = defaultPublishOptions & #orderingPolicy .~ PerSourceStream - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing) - summary ^. #published `shouldBe` 2 - summary ^. #rejected `shouldBe` 1 - Right (Just successor) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - successor ^. #status `shouldBe` OutboxSent - - it "counts only a rejection finalization that wins the publishing-state race" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - let strandedAt = addUTCTime (-3600) now - maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1 - publish _ = do - backdateOutboxUpdatedAt oid strandedAt - _ <- outboxMaintenancePass maintenanceOptions Nothing - pure (PublishRejected rejection) - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing - summary ^. #claimed `shouldBe` 1 - summary ^. #published `shouldBe` 0 - summary ^. #rejected `shouldBe` 0 - summary ^. #retried `shouldBe` 0 - summary ^. #dead `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxFailed - row ^. #rejection `shouldBe` Nothing - - it "excludes rejected rows from claims, maintenance, backlog, and sent garbage collection" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - rejection <- shouldBeRight (mkPublishRejection "invalid.destination" (Just "destination was removed")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) defaultPublishOptions Nothing - summary ^. #rejected `shouldBe` 1 - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid (addUTCTime (-3600) now)) - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) - claimed `shouldBe` [] - Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) - maintenance ^. #requeued `shouldBe` 0 - maintenance ^. #deadLettered `shouldBe` 0 - maintenance ^. #backlog `shouldBe` 0 - Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 0 now) - deleted `shouldBe` 0 - Right (Just retained) <- Store.runStoreIO storeHandle (lookupOutbox oid) - retained ^. #status `shouldBe` OutboxRejected - - it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - row4Id = outboxIdFromOrdinal 4 - row5Id = outboxIdFromOrdinal 5 - ids = [row1Id, row2Id, row3Id, row4Id, row5Id] - rows = - [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key") - | (i, oid) <- zip [1 .. 5 :: Int] ids - ] - publish claimed = - pure - [ ( row ^. #outboxId, - if row ^. #outboxId == row3Id - then PublishFailed "pivot failed" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #published `shouldBe` 2 - summary ^. #retried `shouldBe` 3 - Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) - Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) - Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) - Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id) - row1 ^. #status `shouldBe` OutboxSent - row2 ^. #status `shouldBe` OutboxSent - row3 ^. #status `shouldBe` OutboxFailed - row3 ^. #attemptCount `shouldBe` 1 - row3 ^. #lastError `shouldBe` Just "pivot failed" - row4 ^. #status `shouldBe` OutboxFailed - row4 ^. #attemptCount `shouldBe` 0 - row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed" - row5 ^. #status `shouldBe` OutboxFailed - row5 ^. #attemptCount `shouldBe` 0 - - it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do - let rowA1 = outboxIdFromOrdinal 1 - rowB1 = outboxIdFromOrdinal 2 - rowA2 = outboxIdFromOrdinal 3 - rowB2 = outboxIdFromOrdinal 4 - mkRow oid src msgId = - (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing) - rows = - [ mkRow rowA1 "per-source-a" "ps-a1", - mkRow rowB1 "per-source-b" "ps-b1", - mkRow rowA2 "per-source-a" "ps-a2", - mkRow rowB2 "per-source-b" "ps-b2" - ] - publish claimed = - pure - [ ( row ^. #outboxId, - if row ^. #outboxId == rowA2 - then PublishFailed "source-a pivot failed" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #claimed `shouldBe` 4 - summary ^. #published `shouldBe` 3 - summary ^. #retried `shouldBe` 1 - Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1) - Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2) - Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1) - Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2) - a1 ^. #status `shouldBe` OutboxSent - a2 ^. #status `shouldBe` OutboxFailed - a2 ^. #attemptCount `shouldBe` 1 - a2 ^. #lastError `shouldBe` Just "source-a pivot failed" - b1 ^. #status `shouldBe` OutboxSent - b2 ^. #status `shouldBe` OutboxSent - - it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - now <- getCurrentTime - Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) - Right lateResult <- - Store.runStoreIO storeHandle $ - Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now) - lateResult `shouldBe` Nothing - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxSent - row ^. #lastError `shouldBe` Nothing - - it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do - let headId = outboxIdFromOrdinal 1 - tailId = outboxIdFromOrdinal 2 - rows = - [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key"), - (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key") - ] - OutboxId headUuid = headId - holdClaimSql = - TE.encodeUtf8 $ - "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '" - <> UUID.toText headUuid - <> "'" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - holderDone <- newEmptyMVar - _ <- forkIO $ do - holder <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.sql holdClaimSql - Tx.sql "SELECT pg_sleep(2)" - putMVar holderDone holder - -- Let the holder acquire its uncommitted row lock, then race a claim. - threadDelay 500000 - now <- getCurrentTime - Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) - fmap (^. #outboxId) claimed `shouldBe` [] - Right () <- takeMVar holderDone - pure () - - it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - row4Id = outboxIdFromOrdinal 4 - ids = [row1Id, row2Id, row3Id, row4Id] - rows = - [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key") - | (i, oid) <- zip [1 .. 4 :: Int] ids - ] - publishRef = fmap (^. #outboxId) - publish claimed = - pure - [ ( row ^. #outboxId, - if row ^. #outboxId == row2Id - then PublishFailed "stop here" - else PublishSucceeded - ) - | row <- claimed - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - seenRef <- newIORef [] - let trackedPublish claimed = do - liftIO (modifyIORef' seenRef (<> publishRef claimed)) - publish claimed - opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 3 - summary ^. #haltedOn `shouldBe` Just row2Id - seen <- readIORef seenRef - seen `shouldBe` take 2 ids - Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) - Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) - row3 ^. #status `shouldBe` OutboxFailed - row3 ^. #attemptCount `shouldBe` 0 - row4 ^. #status `shouldBe` OutboxFailed - row4 ^. #attemptCount `shouldBe` 0 - - it "StopTheLine continues after rejection and halts only on transient failure" $ \storeHandle -> do - let row1Id = outboxIdFromOrdinal 1 - row2Id = outboxIdFromOrdinal 2 - row3Id = outboxIdFromOrdinal 3 - row4Id = outboxIdFromOrdinal 4 - ids = [row1Id, row2Id, row3Id, row4Id] - rows = - [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-reject-" <> Text.pack (show i)) & #key .~ Just "stop-reject-key") - | (i, oid) <- zip [1 .. 4 :: Int] ids - ] - rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - traverse_ (uncurry enqueueIntegrationEventTx) rows - seenRef <- newIORef [] - let publish claimed = do - liftIO (modifyIORef' seenRef (<> fmap (^. #outboxId) claimed)) - pure - [ ( row ^. #outboxId, - if row ^. #outboxId == row1Id - then PublishRejected rejection - else - if row ^. #outboxId == row3Id - then PublishFailed "stop after rejection" - else PublishSucceeded - ) - | row <- claimed - ] - opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #rejected `shouldBe` 1 - summary ^. #retried `shouldBe` 2 - summary ^. #haltedOn `shouldBe` Just row3Id - readIORef seenRef `shouldReturn` take 3 ids - Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) - row4 ^. #status `shouldBe` OutboxFailed - row4 ^. #attemptCount `shouldBe` 0 - - it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do - let okId = outboxIdFromOrdinal 1 - missingId = outboxIdFromOrdinal 2 - okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key" - missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key" - publish claimed = - pure - [ (row ^. #outboxId, PublishSucceeded) - | row <- claimed, - row ^. #outboxId == okId - ] - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - enqueueIntegrationEventTx okId okEvent - enqueueIntegrationEventTx missingId missingEvent - Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId) - missingRow ^. #status `shouldBe` OutboxFailed - missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome" - - it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do - let oid = OutboxId outboxUuid1 - event = sampleIntegrationEnvelope & #key .~ Nothing - opts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 3 - & #backoff - .~ ConstantBackoff 0 - & #orderingPolicy - .~ BestEffort - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid event) - let publish _ = pure (PublishFailed "broker exploded") - -- First two failures retain Failed status. - Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s1 ^. #retried `shouldBe` 1 - s1 ^. #dead `shouldBe` 0 - Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s2 ^. #retried `shouldBe` 1 - s2 ^. #dead `shouldBe` 0 - -- Third failure crosses the threshold. - Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - s3 ^. #dead `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) - row ^. #status `shouldBe` OutboxDead - -- A dead row is not claimable. - now <- getCurrentTime - Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) - reclaimed `shouldBe` [] - - it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do - let oldSentId = OutboxId outboxUuid1 - recentSentId = OutboxId outboxUuid2 - failedId = OutboxId outboxUuid3 - deadId = OutboxId outboxUuid4 - base = sampleIntegrationEnvelope & #key .~ Nothing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed")) - let firstPass row - | row ^. #outboxId == failedId = pure (PublishFailed "keep failed") - | otherwise = pure PublishSucceeded - firstPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #orderingPolicy - .~ BestEffort - & #backoff - .~ ConstantBackoff 3600 - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead")) - let deadPass row - | row ^. #outboxId == deadId = pure (PublishFailed "keep dead") - | otherwise = pure PublishSucceeded - deadPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 1 - & #orderingPolicy - .~ BestEffort - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing) - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now)) - Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now) - deleted `shouldBe` 1 - Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId) - oldRow `shouldBe` Nothing - Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId) - recentRow ^. #status `shouldBe` OutboxSent - Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId) - failedRow ^. #status `shouldBe` OutboxFailed - Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId) - deadRow ^. #status `shouldBe` OutboxDead - - it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do - let a1Id = OutboxId outboxUuid1 - a2Id = OutboxId outboxUuid2 - b1Id = OutboxId outboxUuid3 - a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1" - a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1" - b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2" - -- Insert in created_at order (a1 first, then a2, then b1). - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx a1Id a1) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx a2Id a2) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx b1Id b1) - claimed <- newIORef [] - let publish row = do - liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) - if row ^. #outboxId == a1Id - then pure (PublishFailed "broker hiccup") - else pure PublishSucceeded - -- First pass: with a one-row batch, a1 fails and both later rows remain pending. - let firstPassOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - Right summary1 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing) - summary1 ^. #claimed `shouldBe` 1 - claimedIds <- readIORef claimed - claimedIds `shouldSatisfy` (a2Id `notElem`) - claimedIds `shouldSatisfy` (a1Id `elem`) - claimedIds `shouldSatisfy` (b1Id `notElem`) - Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id) - a1Row ^. #status `shouldBe` OutboxFailed - Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id) - b1Row ^. #status `shouldBe` OutboxPending - Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row ^. #status `shouldBe` OutboxPending - -- Drive a1 to terminal sent state so a2 can move. One pass claims a1 - -- (now that next_attempt_at has passed). A second pass claims a2, - -- which becomes head-of-line once a1 reaches `sent`. - writeIORef claimed [] - let publishOk row = do - liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) - pure PublishSucceeded - retryOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) - claimedIds2 <- readIORef claimed - claimedIds2 `shouldSatisfy` (a1Id `elem`) - claimedIds2 `shouldSatisfy` (a2Id `elem`) - claimedIds2 `shouldSatisfy` (b1Id `elem`) - Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id) - a2Row' ^. #status `shouldBe` OutboxSent - - it "allows null-keyed rows to publish independently" $ \storeHandle -> do - let n1 = OutboxId outboxUuid1 - n2 = OutboxId outboxUuid2 - e = sampleIntegrationEnvelope & #key .~ Nothing - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2")) - let publish row - | row ^. #outboxId == n1 = pure (PublishFailed "transient") - | otherwise = pure PublishSucceeded - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing - summary ^. #claimed `shouldBe` 2 - summary ^. #published `shouldBe` 1 - summary ^. #retried `shouldBe` 1 - - it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do - Right minted <- - Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft) - minted ^. #source `shouldBe` "ordering" - minted ^. #destination `shouldBe` "billing.orders.v1" - Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True - - it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do - shouldBeRight_ (mkIntegrationProducer sampleProducer) - case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of - Left (InvalidMessageIdPrefix prefix reason) -> do - prefix `shouldBe` "Bad-Prefix" - reason `shouldSatisfy` (not . Text.null) - other -> expectationFailure ("expected invalid prefix, got " <> show (void other)) - - it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do - let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft - event ^. #messageId `shouldBe` "msg-fixed-1" - event ^. #source `shouldBe` "ordering" - event ^. #destination `shouldBe` "billing.orders.v1" - - it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do - Right ids <- - Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int]) - length ids `shouldBe` 4 - length (uniqueIds ids) `shouldBe` 4 - - it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - okEvent = sampleIntegrationEnvelope - failEvent = - sampleIntegrationEnvelope - & #messageId - .~ "msg-fail-otel-1" - & #key - .~ Just "order-otel-fail" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | otherwise = pure (PublishFailed "broker unreachable") - opts = defaultPublishOptions & #tracer ?~ tracer - Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 1 - case spans of - [batchSpan] -> do - csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination)) - show (csKind batchSpan) `shouldBe` "Producer" - textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka" - textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish" - textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send" - textAttr (csAttributes batchSpan) "messaging.destination.name" - `shouldBe` Just (okEvent ^. #destination) - textAttr (csAttributes batchSpan) "messaging.kafka.message.key" - `shouldBe` (okEvent ^. #key) - intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2 - textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed" - case csStatus batchSpan of - Error msg -> msg `shouldBe` "broker unreachable" - other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other) - other -> expectationFailure ("expected one batch span, got " <> show (length other)) - - it "does not mark a terminal rejection span as an error" $ \storeHandle -> do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "operator policy")) - let tracer = makeTracer provider "keiro-test" tracerOptions - oid = OutboxId outboxUuid1 - opts = defaultPublishOptions & #tracer ?~ tracer - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) - Right summary <- - Store.runStoreIO storeHandle $ - publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) opts Nothing - summary ^. #rejected `shouldBe` 1 - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - case spans of - [batchSpan] -> do - textAttr (csAttributes batchSpan) "error.type" `shouldBe` Nothing - case csStatus batchSpan of - Unset -> pure () - Ok -> pure () - other -> expectationFailure ("expected rejection span to be Unset/Ok, got " <> show other) - other -> expectationFailure ("expected one rejection span, got " <> show (length other)) - - it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let okId = OutboxId outboxUuid1 - failId = OutboxId outboxUuid2 - rejectId = OutboxId outboxUuid3 - okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing - failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing - rejectEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-reject" & #key .~ Nothing - rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "not routed")) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx okId okEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx failId failEvent) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (enqueueIntegrationEventTx rejectId rejectEvent) - let publish row - | row ^. #outboxId == okId = pure PublishSucceeded - | row ^. #outboxId == rejectId = pure (PublishRejected rejection) - | otherwise = pure (PublishFailed "broker down") - retryPassOpts = - defaultPublishOptions - & #batchSize - .~ 10 - & #maxAttempts - .~ 5 - & #backoff - .~ ConstantBackoff 0 - & #orderingPolicy - .~ BestEffort - deadPassOpts = retryPassOpts & #maxAttempts .~ 1 - -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries. - Right summary1 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics)) - summary1 ^. #published `shouldBe` 1 - summary1 ^. #rejected `shouldBe` 1 - summary1 ^. #retried `shouldBe` 1 - -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies. - Right summary2 <- - Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics)) - summary2 ^. #dead `shouldBe` 1 - -- Flush so the in-memory exporter receives the aggregates. - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - -- Counters are cumulative across both passes. - lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.outbox.rejected" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1) - -- Publish passes no longer run the backlog COUNT(*) on the hot path. - lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing - - Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right () - _ <- forceFlushMeterProvider provider Nothing - sampled <- readIORef metricsRef - let sampledScalars = flattenScalarPoints sampled - lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) - - describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do - it "runs the handler once and records the row as completed" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-1" - & #source - .~ "ordering" - handler ev = - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - case result1 of - Right (InboxProcessed ()) -> pure () - other -> expectationFailure ("expected InboxProcessed, got " <> show other) - Right rowCount1 <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount1 `shouldBe` 1 - Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1") - inboxRow ^. #status `shouldBe` InboxCompleted - inboxRow ^. #completedAt `shouldSatisfy` isJust - - it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-dup" - & #source - .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - result2 `shouldBe` Right InboxDuplicate - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - -- First delivery runs the handler: processed. - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler - -- Second delivery of the same (source, message_id): duplicate. - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler - result2 `shouldBe` Right InboxDuplicate - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing - Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right () - _ <- forceFlushMeterProvider provider Nothing - sampled <- readIORef metricsRef - let sampledScalars = flattenScalarPoints sampled - lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) - -- The handler ran exactly once (the duplicate path does not re-run it). - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let shared = sampleIntegrationEnvelope & #source .~ "ordering" - first = shared & #messageId .~ "republish-1" - second = shared & #messageId .~ "republish-2" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler - result2 `shouldBe` Right InboxDuplicate - - it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = sampleIntegrationEnvelope & #source .~ "ordering" - kafka = KafkaDeliveryRef "billing.orders.v1" 0 17 - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler - Right (Right InboxDuplicate) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler - Right (Just row) <- - Store.runStoreIO storeHandle $ - lookupInbox "ordering" "billing.orders.v1:0:17" - row ^. #status `shouldBe` InboxCompleted - - it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #source - .~ "ordering" - & #sourceEventId - .~ Nothing - & #sourceGlobalPosition - .~ Nothing - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ()) - result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity) - - it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-rollback" - & #source - .~ "ordering" - handler _ = do - Tx.condemn - pure () - _ <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback") - row `shouldBe` Nothing - - it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-throw-plain" - & #source - .~ "ordering" - handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction () - thrown <- - try $ - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - case thrown of - Left (_ :: SomeException) -> pure () - Right other -> expectationFailure ("expected handler exception, got " <> show (void other)) - Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain") - row `shouldBe` Nothing - - it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-public-failed" - & #source - .~ "ordering" - handler _ = do - markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt) - pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed") - row ^. #status `shouldBe` InboxFailed - row ^. #lastError `shouldBe` Just "operator failed" - - it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-1" - & #source - .~ "ordering" - handler _ = (pure $! error "inbox exploded") :: Tx.Transaction () - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler - case result of - Right (InboxHandlerFailed err attempts) -> do - Text.isInfixOf "inbox exploded" err `shouldBe` True - attempts `shouldBe` 1 - other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 1 - row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded") - - it "a transient poison message succeeds on retry" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-transient" - & #source - .~ "ordering" - failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction () - succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce - case result1 of - Right (InboxHandlerFailed _ 1) -> pure () - other -> expectationFailure ("expected first failed attempt, got " <> show other) - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding - result2 `shouldBe` Right (InboxProcessed ()) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient") - row ^. #status `shouldBe` InboxCompleted - row ^. #attemptCount `shouldBe` 1 - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-poison-dead" - & #source - .~ "ordering" - handler _ = (pure $! error "always broken") :: Tx.Transaction () - Right result1 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - Right result2 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - Right result3 <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler - case (result1, result2, result3) of - ( Right (InboxHandlerFailed _ 1), - Right (InboxHandlerFailed _ 2), - Right (InboxPreviouslyFailed _) - ) -> pure () - other -> expectationFailure ("unexpected poison lifecycle: " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 2 - - it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-msg-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 50 :: Int] - ] - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - results `shouldBe` replicate 50 (Right (InboxProcessed ())) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 50 - Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering") - length inboxRows `shouldBe` 50 - all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True - - it "deduplicates repeated messages within one batch" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-batch-dup" - & #source - .~ "batch-ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler - results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate] - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "falls back per message when one batch handler throws" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-poison-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 5 :: Int] - ] - handler ev - | ev ^. #messageId == "inbox-batch-poison-3" = - (pure $! error "batch poison") :: Tx.Transaction () - | otherwise = - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - case results of - [ Right (InboxProcessed ()), - Right (InboxProcessed ()), - Right (InboxHandlerFailed err 1), - Right (InboxProcessed ()), - Right (InboxProcessed ()) - ] -> - Text.isInfixOf "batch poison" err `shouldBe` True - other -> expectationFailure ("unexpected batch fallback results: " <> show other) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 4 - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3") - row ^. #status `shouldBe` InboxFailed - row ^. #attemptCount `shouldBe` 1 - row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison") - - it "reports duplicates across batch calls" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-batch-existing-dup" - & #source - .~ "batch-ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right first <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler - first `shouldBe` [Right (InboxProcessed ())] - Right second <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler - second `shouldBe` [Right InboxDuplicate] - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let events = - [ sampleIntegrationEnvelope - & #messageId - .~ ("inbox-batch-condemn-" <> Text.pack (show n)) - & #source - .~ "batch-ordering" - | n <- [1 .. 3 :: Int] - ] - handler ev - | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn - | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right results <- - Store.runStoreIO storeHandle $ - runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler - -- The condemned single-message retry reports processed by the - -- documented single-path contract; what matters is that the - -- innocent batch mates actually committed. - results `shouldBe` replicate 3 (Right (InboxProcessed ())) - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 2 - Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1") - Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3") - mate1 ^. #status `shouldBe` InboxCompleted - mate3 ^. #status `shouldBe` InboxCompleted - Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2") - condemned `shouldBe` Nothing - - it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-legacy-processing" - & #source - .~ "ordering" - handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')" - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - result `shouldBe` Right InboxInProgress - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing") - row ^. #status `shouldBe` InboxProcessing - - it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-race-dup" - & #source - .~ "ordering" - slowHandler ev = do - Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - Tx.sql "SELECT pg_sleep(1.5)" - fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt - firstDone <- newEmptyMVar - _ <- forkIO $ do - first <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler - putMVar firstDone first - -- Let the slow worker insert its uncommitted row, then race the - -- same dedupe key: the second insert must block on the unique - -- constraint until the first commits, then classify as duplicate. - threadDelay 400000 - Right second <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler - Right first <- takeMVar firstDone - first `shouldBe` Right (InboxProcessed ()) - second `shouldBe` Right InboxDuplicate - Right rowCount <- - Store.runStoreIO storeHandle $ - Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) - rowCount `shouldBe` 1 - - it "can persist only dedupe columns for successful rows" $ \storeHandle -> do - let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42 - event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-slim-success" - & #source - .~ "ordering" - & #payloadBytes - .~ "full success payload" - & #attributes - ?~ object ["source" Aeson..= ("slim-test" :: Text)] - handler _ = pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success") - row ^. #event . #payloadBytes `shouldBe` "" - row ^. #event . #attributes `shouldBe` Nothing - row ^. #event . #traceContext `shouldBe` Nothing - row ^. #event . #schemaReference `shouldBe` Nothing - row ^. #event . #messageId `shouldBe` "inbox-slim-success" - row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId - row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition - row ^. #event . #causationId `shouldBe` event ^. #causationId - row ^. #event . #correlationId `shouldBe` event ^. #correlationId - row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt - row ^. #kafka `shouldBe` Just kafka - Right redelivery <- - Store.runStoreIO storeHandle $ - runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler - redelivery `shouldBe` Right InboxDuplicate - - it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-slim-failed" - & #source - .~ "ordering" - & #payloadBytes - .~ "full failed payload" - & #attributes - ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)] - handler _ = (pure $! error "slim failure") :: Tx.Transaction () - Right result <- - Store.runStoreIO storeHandle $ - runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler - case result of - Right (InboxHandlerFailed err 1) -> - Text.isInfixOf "slim failure" err `shouldBe` True - other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) - Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed") - row ^. #status `shouldBe` InboxFailed - row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes - row ^. #event . #attributes `shouldBe` event ^. #attributes - row ^. #event . #traceContext `shouldBe` event ^. #traceContext - row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference - - it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do - let event = - sampleIntegrationEnvelope - & #messageId - .~ "inbox-msg-gc" - & #source - .~ "ordering" - handler _ = pure () - Right (Right (InboxProcessed ())) <- - Store.runStoreIO storeHandle $ - runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler - -- Backdate the row so it falls outside the retention window. - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql - "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'" - now <- getCurrentTime - Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now) - deleted `shouldBe` 1 - Right rows <- Store.runStoreIO storeHandle (listInbox "ordering") - rows `shouldBe` [] - - describe "Keiro.Inbox.Kafka" $ do - it "reconstructs an integration event from headers and payload" $ do - let envelope = sampleIntegrationEnvelope - headers = integrationHeaders envelope - receivedAt = addUTCTime 60 (envelope ^. #occurredAt) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1", - partition = 2, - offset = 113, - key = Just "order-123", - payload = envelope ^. #payloadBytes, - headers, - receivedAt - } - case InboxKafka.integrationEventFromKafka record of - Right (rebuilt, kafkaRef) -> do - rebuilt ^. #messageId `shouldBe` envelope ^. #messageId - rebuilt ^. #source `shouldBe` envelope ^. #source - rebuilt ^. #destination `shouldBe` envelope ^. #destination - rebuilt ^. #eventType `shouldBe` envelope ^. #eventType - rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion - rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId - rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition - rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes - rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt - rebuilt ^. #attributes `shouldBe` envelope ^. #attributes - kafkaRef ^. #topic `shouldBe` "billing.orders.v1" - kafkaRef ^. #partition `shouldBe` 2 - kafkaRef ^. #offset `shouldBe` 113 - Left err -> expectationFailure ("expected Right, got Left " <> show err) - - it "falls back to receivedAt when the occurredAt header is absent" $ do - let envelope = sampleIntegrationEnvelope - receivedAt = addUTCTime 60 (envelope ^. #occurredAt) - headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1", - partition = 2, - offset = 113, - key = Just "order-123", - payload = envelope ^. #payloadBytes, - headers, - receivedAt - } - case InboxKafka.integrationEventFromKafka record of - Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt - Left err -> expectationFailure ("expected Right, got Left " <> show err) - - it "rejects malformed occurredAt headers" $ do - let envelope = sampleIntegrationEnvelope - headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1", - partition = 2, - offset = 113, - key = Just "order-123", - payload = envelope ^. #payloadBytes, - headers, - receivedAt = envelope ^. #occurredAt - } - InboxKafka.integrationEventFromKafka record - `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time") - - it "reports MissingHeader for an essential header" $ do - let envelope = sampleIntegrationEnvelope - headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope) - record = - InboxKafka.KafkaInboundRecord - { topic = "billing.orders.v1", - partition = 0, - offset = 0, - key = Nothing, - payload = envelope ^. #payloadBytes, - headers, - receivedAt = envelope ^. #occurredAt - } - InboxKafka.integrationEventFromKafka record - `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id") - - it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do - (processor, spansRef) <- inMemoryListExporter - provider <- createTracerProvider [processor] emptyTracerProviderOptions - let tracer = makeTracer provider "keiro-test" tracerOptions - -- Clear the baked-in TraceContext on the sample so the only - -- `traceparent` on the wire comes from the active producer - -- span (via `injectTraceContext`). - envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing - producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope - producerHeadersText <- - Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do - let baseHeaders = - [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers] - Telemetry.injectTraceContext baseHeaders - -- Build the inbound record the consumer would receive and open the - -- consumer span around a no-op body. - now <- getCurrentTime - let inbound = - InboxKafka.KafkaInboundRecord - { topic = envelope ^. #destination, - partition = 7, - offset = 42, - key = envelope ^. #key, - payload = envelope ^. #payloadBytes, - headers = producerHeadersText, - receivedAt = now - } - Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ -> - pure () - _ <- shutdownTracerProvider provider Nothing - spans <- traverse captureSpan =<< readIORef spansRef - length spans `shouldBe` 2 - let findByName needle = case [s | s <- spans, csName s == needle] of - (s : _) -> s - [] -> error ("no span captured with name=" <> Text.unpack needle) - producerSp = findByName ("send " <> envelope ^. #destination) - consumerSp = findByName ("process " <> envelope ^. #destination) - -- Same trace id end-to-end (cross-process parenting). - traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp) - -- Consumer's parent is the producer span. - case csParent consumerSp of - Nothing -> expectationFailure "consumer span has no parent" - Just parent -> do - parentCtx <- getSpanContext parent - spanId parentCtx `shouldBe` spanId (csContext producerSp) - -- Consumer span carries the expected attributes. - show (csKind consumerSp) `shouldBe` "Consumer" - textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka" - textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process" - textAttr (csAttributes consumerSp) "messaging.destination.name" - `shouldBe` Just (envelope ^. #destination) - textAttr (csAttributes consumerSp) "messaging.destination.partition.id" - `shouldBe` Just "7" - textAttr (csAttributes consumerSp) "messaging.consumer.group.name" - `shouldBe` Just "billing-cg" - textAttr (csAttributes consumerSp) "messaging.message.id" - `shouldBe` Just (envelope ^. #messageId) - - describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do - it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - topic <- newKafkaTopic - -- Ordering side: enqueue an outbox row representing a published event. - let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa" - oid = OutboxId outboxUuid1 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent) - -- Run the publisher worker: push records to the in-process topic. - Right pubSummary1 <- - Store.runStoreIO ordering $ - publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing - pubSummary1 ^. #published `shouldBe` 1 - -- Billing side: consume from the topic. - records1 <- drainKafkaTopic topic - record1 <- case records1 of - [r] -> pure r - other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" - Right consumed1 <- - Store.runStoreIO billing $ - consumeAndApply record1 billingReactionHandler - consumed1 `shouldBe` ConsumeApplied (InboxProcessed ()) - Right rowCount1 <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) - rowCount1 `shouldBe` 1 - - -- Simulate Kafka redelivery: pretend the same Kafka record was - -- delivered again at a different offset. The producer also retries - -- (the outbox flips back to pending and the worker republishes). - let redelivered = redeliverWithDifferentOffset record1 - Right consumed2 <- - Store.runStoreIO billing $ - consumeAndApply redelivered billingReactionHandler - consumed2 `shouldBe` ConsumeApplied InboxDuplicate - Right rowCount2 <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) - rowCount2 `shouldBe` 1 - - it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)") - topic <- newKafkaTopic - -- Two events for the same order key. - let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1" - cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2" - submittedId = OutboxId outboxUuid1 - cancelledId = OutboxId outboxUuid2 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv) - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv) - -- Run-claiming lets a same-key contiguous run drain in one pass. - let drainOnce = - publishClaimedOutbox - (perRow (kafkaTopicPublish topic)) - (defaultPublishOptions & #backoff .~ ConstantBackoff 0) - Nothing - Right s1 <- Store.runStoreIO ordering drainOnce - Right s2 <- Store.runStoreIO ordering drainOnce - (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2 - records <- drainKafkaTopic topic - length records `shouldBe` 2 - -- Apply both records to billing in delivery order. - for_ records $ \record -> do - Right consumed <- - Store.runStoreIO billing $ - consumeAndApply record (loggingReactionHandler "billing") - case consumed of - ConsumeApplied (InboxProcessed ()) -> pure () - other -> expectationFailure ("expected processed, got " <> show other) - Right events <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.statement () billingEventLogStmt) - events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")] - - it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do - Right () <- - Store.runStoreIO billing $ - Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") - topic <- newKafkaTopic - let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1" - cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2" - firstId = OutboxId outboxUuid1 - secondId = OutboxId outboxUuid2 - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv) - Right () <- - Store.runStoreIO ordering $ - Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv) - -- Failing publish for the first row, success for any other. - let publish row - | row ^. #outboxId == firstId = - pure (PublishFailed "simulated broker reject") - | otherwise = do - kafkaTopicAccept topic row - pure PublishSucceeded - deadOpts = - defaultPublishOptions - & #batchSize - .~ 1 - & #backoff - .~ ConstantBackoff 0 - & #maxAttempts - .~ 2 - -- This test drives the pre-M3 sequential failure/dead-letter path - -- with one-row batches. M3 adds suffix skipping for larger claimed - -- same-key runs. - -- First pass: the first row attempts once and fails; the second is - -- outside the one-row claim window. - Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass1 ^. #retried `shouldBe` 1 - pass1 ^. #published `shouldBe` 0 - -- Second pass crosses maxAttempts and dead-letters the first row. - Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass2 ^. #dead `shouldBe` 1 - Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId) - firstRow ^. #status `shouldBe` OutboxDead - -- With the first row dead, the second becomes claimable and publishes. - Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) - pass3 ^. #published `shouldBe` 1 - Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId) - secondRow ^. #status `shouldBe` OutboxSent - -- Billing only sees the second event. - records <- drainKafkaTopic topic - record <- case records of - [r] -> pure r - other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" - Right consumed <- - Store.runStoreIO billing $ - consumeAndApply record billingReactionHandler - consumed `shouldBe` ConsumeApplied (InboxProcessed ()) - - describe "Keiro.Integration.Event" $ do - it "round-trips a JSON envelope through encode and decode" $ do - let envelope = sampleIntegrationEnvelope - payload = OrderSubmittedPayload "order-123" 5 - encoded = encodeJsonIntegrationEvent envelope payload - decodeJsonIntegrationEvent encoded `shouldBe` Right payload - - it "preserves identity and routing through encode" $ do - let envelope = sampleIntegrationEnvelope - encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) - encoded ^. #messageId `shouldBe` envelope ^. #messageId - encoded ^. #source `shouldBe` "ordering" - encoded ^. #destination `shouldBe` "billing.orders.v1" - encoded ^. #key `shouldBe` Just "order-123" - encoded ^. #eventType `shouldBe` "OrderSubmitted" - encoded ^. #schemaVersion `shouldBe` 1 - encoded ^. #contentType `shouldBe` ApplicationJson - - it "emits the canonical wire headers" $ do - let envelope = sampleIntegrationEnvelope - headers = integrationHeaders envelope - Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId) - Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1" - Prelude.lookup headerContentType headers `shouldBe` Just "application/json" - Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted" - Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003" - Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42" - Prelude.lookup headerTraceParent headers - `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" - - it "preserves a different content type without claiming JSON" $ do - let envelope = - sampleIntegrationEnvelope - & #contentType - .~ OtherContentType "application/vnd.apache.avro.binary" - & #payloadBytes - .~ "\x00\x01\x02" - headers = integrationHeaders envelope - Prelude.lookup headerContentType headers - `shouldBe` Just "application/vnd.apache.avro.binary" - decodeJsonIntegrationEvent envelope - `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") :: - Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload - ) - - it "reports malformed JSON payloads as decode errors instead of throwing" $ do - let envelope = - sampleIntegrationEnvelope - & #payloadBytes - .~ "{not-json" - case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of - Left (IntegrationEvent.MalformedPayload _) -> pure () - other -> expectationFailure ("expected MalformedPayload, got " <> show other) - - it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do - let envelope = - sampleIntegrationEnvelope - & #payloadBytes - .~ "{\"orderId\":\"order-123\"}" - case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of - Left (IntegrationEvent.DecodeFailed _) -> pure () - other -> expectationFailure ("expected DecodeFailed, got " <> show other) - - it "parses content-type headers back to the canonical type" $ do - parseContentType "application/json" `shouldBe` ApplicationJson - parseContentType "Application/JSON" `shouldBe` ApplicationJson - parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson - parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson - parseContentType "application/vnd.apache.avro.binary" - `shouldBe` OtherContentType "application/vnd.apache.avro.binary" - - it "preserves the payload bytes through integrationPayload" $ do - let envelope = sampleIntegrationEnvelope - encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) - integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes) - - describe "Keiro.Telemetry" $ do - it "is a pass-through under a noop (Nothing) tracer" $ do - counter <- newIORef (0 :: Int) - let envelope = sampleIntegrationEnvelope - record = OutboxKafka.integrationEventToKafkaRecord envelope - result <- - Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do - atomicModifyIORef' counter (\n -> (n + 1, ())) - pure (mSpan, "ok" :: Text) - callsAfter <- readIORef counter - callsAfter `shouldBe` (1 :: Int) - snd result `shouldBe` "ok" - fst result `shouldSatisfy` isNothing - - it "re-exports AttributeKeys whose textual payload matches the spec name" $ do - attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type" - attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name" - attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id" - attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name" - attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id" - attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset" - attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name" - attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace" - attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name" - attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name" - attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name" - attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt" - attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended" - attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence" - - it "extracts a TraceContext from a W3C traceparent header pair" $ do - let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" - tracestate = "vendor1=value1" - hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)] - Telemetry.traceContextFromHeaders hs - `shouldBe` Just (TraceContext traceparent (Just tracestate)) - - it "returns Nothing when the traceparent header is missing" $ do - Telemetry.traceContextFromHeaders [("content-type", "application/json")] - `shouldBe` Nothing - - it "injectTraceContext is a no-op when no span is active on the thread" $ do - let baseline = [("content-type", "application/json")] - injected <- Telemetry.injectTraceContext baseline - injected `shouldBe` baseline - - it "traceContextFromCurrentSpan returns Nothing outside any span" $ do - tc <- Telemetry.traceContextFromCurrentSpan - tc `shouldBe` Nothing - - describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do - it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "demo" - wid = WorkflowId "demo-1" - result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - result `shouldBe` Right (Completed (1, 2)) - sideEffects <- readIORef counter - sideEffects `shouldBe` 2 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 3 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True - _ -> False - - it "replays recorded steps without re-running their side effects" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "replay" - wid = WorkflowId "r-1" - first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - first `shouldBe` Right (Completed (1, 2)) - afterFirst <- readIORef counter - afterFirst `shouldBe` 2 - -- A second run with the same id is exactly the crash-restart scenario. - second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - second `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - -- The deterministic ids and pre-load gating leave the journal at 3 events. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 3 - - it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "samename" - wid = WorkflowId "s-1" - duplicateStepWorkflow = do - a <- step (StepName "dup") (liftIO (incrementAndRead counter)) - b <- step (StepName "dup") (liftIO (incrementAndRead counter)) - pure (a, b) - result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow - result `shouldBe` Right (Completed (1, 1)) - sideEffects <- readIORef counter - sideEffects `shouldBe` 1 - - it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do - let name = WorkflowName "awaiter" - wid = WorkflowId "a-1" - result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - result `shouldBe` Right Suspended - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 0 - - it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do - let name = WorkflowName "awaiter2" - wid = WorkflowId "a-2" - suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - suspended `shouldBe` Right Suspended - -- Simulate a wake source recording the awaited step's resolution. - Right () <- Store.runStoreIO storeHandle $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now) - resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - resumed `shouldBe` Right (Completed 42) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True - _ -> False - - it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do - let name = WorkflowName "duplicate-append" - wid = WorkflowId "da-1" - stepKey = "awk:test" - eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t - now <- getCurrentTime - Right firstId <- - Store.runStoreIO storeHandle $ - appendJournalEntryReturningId name wid (eventAt now) - secondResult <- - Store.runStoreIO storeHandle $ - appendJournalEntryReturningId name wid (eventAt now) - secondId <- case secondResult of - Right value -> pure value - Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable" - secondId `shouldBe` firstId - Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0 - Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int)) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do - let name = WorkflowName "journal-race" - wid = WorkflowId "jr-1" - body = - step (StepName "raced") $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now) - pure ("loser" :: Text) - outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body - outcome `shouldBe` Right (Completed "winner") - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text) - _ -> False - - it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do - let name = WorkflowName "roundtrip-step" - wid = WorkflowId "rs-1" - body = step (StepName "approx") (pure (Approx 1.7)) - first <- Store.runStoreIO storeHandle $ runWorkflow name wid body - first `shouldBe` Right (Completed (Approx 2.0)) - replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body - replay `shouldBe` Right (Completed (Approx 2.0)) - - it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do - let name = WorkflowName "bad-roundtrip" - wid = WorkflowId "br-1" - body = step (StepName "bad") (pure RejectingRoundTrip) - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldThrow` \case - WorkflowStepDecodeError key _ -> key == "bad" - _ -> False - Store.runStoreIO storeHandle (stepExists name wid 0 "bad") - `shouldReturn` Right True - - -- Discovery is exact. A completed workflow is finished, and a workflow - -- parked on an unresolved await has nothing to do until its wake source - -- resolves — the wake's own append is what makes it discoverable again. - it "discovers a parked workflow only once its awaited step is journaled" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter) - parkedAt <- getCurrentTime - Right whileParked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) - whileParked `shouldBe` [] - Right () <- Store.runStoreIO storeHandle $ do - now <- liftIO getCurrentTime - appendJournalEntry - (WorkflowName "pending") - (WorkflowId "p-1") - (StepRecorded "awk:wait" (toJSON (7 :: Int)) now) - wokenAt <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - unfinished `shouldBe` [("p-1", "pending")] - - describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do - it "lists workflow instances with filters and stable keyset pages" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Instance.upsertInstanceTx "b-2" "beta" 0 Instance.WfFailed (Just "boom") - Instance.upsertInstanceTx "a-2" "alpha" 0 Instance.WfCompleted Nothing - Instance.upsertInstanceTx "b-1" "beta" 0 Instance.WfRunning Nothing - Instance.upsertInstanceTx "a-1" "alpha" 0 Instance.WfFailed (Just "bad") - - let firstPageFilter = - Instance.defaultWorkflowInstanceFilter - { Instance.pageSize = 2 - } - Right firstPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances firstPageFilter - fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) firstPage - `shouldBe` [("alpha", "a-1"), ("alpha", "a-2")] - - let secondPageFilter = - firstPageFilter - { Instance.afterKey = Just ("alpha", "a-2") - } - Right secondPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances secondPageFilter - fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) secondPage - `shouldBe` [("beta", "b-1"), ("beta", "b-2")] - - let failedBetaFilter = - Instance.defaultWorkflowInstanceFilter - { Instance.statuses = Just (Instance.WfFailed :| []), - Instance.workflowName = Just "beta" - } - Right failedBeta <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances failedBetaFilter - fmap (\row -> (row ^. #workflowName, row ^. #workflowId, row ^. #status)) failedBeta - `shouldBe` [("beta", "b-2", Instance.WfFailed)] - - it "cancels active workflows idempotently without minting unknown state" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "operator-cancel" - wid = WorkflowId "operator-cancel-1" - completedName = WorkflowName "operator-completed" - completedId = WorkflowId "operator-completed-1" - Left (_ :: SimulatedCrash) <- - try $ - Store.runStoreIO storeHandle $ - runWorkflow name wid (crashAfterStep1 counter) - - Right Instance.WorkflowCancelRecorded <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow name wid - Right Keiro.Workflow.Cancelled <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (threeStep counter) - readIORef counter `shouldReturn` 1 - Right (Instance.WorkflowAlreadyTerminal Instance.WfCancelled) <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow name wid - - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow completedName completedId (demoWorkflow counter) - Right (Instance.WorkflowAlreadyTerminal Instance.WfCompleted) <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow completedName completedId - - Right Instance.WorkflowCancelUnknown <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow (WorkflowName "missing") (WorkflowId "missing-1") - Right Nothing <- - Store.runStoreIO storeHandle $ - Instance.lookupInstance (WorkflowName "missing") (WorkflowId "missing-1") - pure () - - it "cancels suspended and linked-child workflows through supported paths" $ \storeHandle -> do - let suspendedName = WorkflowName "operator-suspended" - suspendedId = WorkflowId "operator-suspended-1" - parentName = WorkflowName "operator-parent" - parentId = WorkflowId "operator-parent-1" - childName = WorkflowName "ship" - childId = WorkflowId "operator-child-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow suspendedName suspendedId neverArmingWorkflow - Right Instance.WorkflowCancelRecorded <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow suspendedName suspendedId - now <- getCurrentTime - Right discovered <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - discovered `shouldNotContain` [("operator-suspended-1", "operator-suspended")] - - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (parentWorkflow childId) - Right Instance.WorkflowCancelRecorded <- - Store.runStoreIO storeHandle $ - Instance.cancelWorkflow childName childId - Store.runStoreIO storeHandle (runWorkflow parentName parentId (parentWorkflow childId)) - `shouldThrow` (== WorkflowChildCancelled childName childId) - - it "serializes cancellation against completion so exactly one marker wins" $ \storeHandle -> do - let name = WorkflowName "operator-terminal-race" - wid = WorkflowId "operator-terminal-race-1" - seededAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) - start <- newEmptyMVar - cancelDone <- newEmptyMVar - completeDone <- newEmptyMVar - _ <- forkIO $ do - takeMVar start - result <- Store.runStoreIO storeHandle $ Instance.cancelWorkflow name wid - putMVar cancelDone result - _ <- forkIO $ do - takeMVar start - completedAt <- getCurrentTime - result <- Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCompleted completedAt) - putMVar completeDone result - putMVar start () - putMVar start () - _ <- takeMVar cancelDone - _ <- takeMVar completeDone - Right hasCancelled <- Store.runStoreIO storeHandle $ stepExists name wid 0 cancelledStepName - Right hasCompleted <- Store.runStoreIO storeHandle $ stepExists name wid 0 completedStepName - (hasCancelled, hasCompleted) `shouldSatisfy` \case - (True, False) -> True - (False, True) -> True - _ -> False - - it "force-releases leases and makes the old owner stop at its next boundary" $ \storeHandle -> do - firstEffect <- newIORef (0 :: Int) - secondEffect <- newIORef (0 :: Int) - let name = WorkflowName "operator-force-release" - wid = WorkflowId "operator-force-release-1" - options owner = - defaultWorkflowRunOptions - & #leaseHeartbeat - .~ Just LeaseHeartbeat {owner, ttl = 60} - body = do - first <- - step (StepName "first") $ do - value <- liftIO (incrementAndRead firstEffect) - released <- Instance.forceReleaseInstanceLease name wid - liftIO (released `shouldBe` True) - pure value - second <- step (StepName "second") (liftIO (incrementAndRead secondEffect)) - pure (first, second) - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 name wid - claimedA `shouldBe` Instance.ClaimAcquired - lost <- - try - ( Store.runStoreIO storeHandle $ - runWorkflowWith (options "owner-a") name wid body - ) :: - IO - ( Either - WorkflowLeaseLost - (Either Store.StoreError (WorkflowOutcome (Int, Int))) - ) - lost `shouldBe` Left WorkflowLeaseLost - readIORef firstEffect `shouldReturn` 1 - readIORef secondEffect `shouldReturn` 0 - Right releasedAgain <- Store.runStoreIO storeHandle $ Instance.forceReleaseInstanceLease name wid - releasedAgain `shouldBe` False - - Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 60 name wid - claimedB `shouldBe` Instance.ClaimAcquired - Right (Completed (1, 1)) <- - Store.runStoreIO storeHandle $ - runWorkflowWith (options "owner-b") name wid body - readIORef firstEffect `shouldReturn` 1 - readIORef secondEffect `shouldReturn` 1 - - it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-complete" - wid = WorkflowId "ic-1" - Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #workflowId `shouldBe` "ic-1" - row ^. #workflowName `shouldBe` "inst-complete" - row ^. #generation `shouldBe` 0 - row ^. #status `shouldBe` Instance.WfCompleted - row ^. #completedAt `shouldSatisfy` isJust - - it "records suspended status for workflows that park before journaling" $ \storeHandle -> do - let name = WorkflowName "inst-suspended" - wid = WorkflowId "is-1" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfSuspended - row ^. #generation `shouldBe` 0 - row ^. #completedAt `shouldBe` Nothing - - it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do - let childWid = WorkflowId "inst-child" - childName = WorkflowName "ship" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid) - Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid - spawned ^. #status `shouldBe` Instance.WfRunning - Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid) - Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid - cancelledRow ^. #status `shouldBe` Instance.WfCancelled - cancelledRow ^. #completedAt `shouldSatisfy` isJust - - it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-rotate" - wid = WorkflowId "ir-1" - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (rollingTotal counter 1 2) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #generation `shouldBe` 1 - row ^. #status `shouldBe` Instance.WfRunning - - it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "inst-terminal" - wid = WorkflowId "it-1" - Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfCompleted - - it "discovers unfinished workflows from the instance table" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let completedName = WorkflowName "discover-completed" - cancelledName = WorkflowName "discover-cancelled" - crashedName = WorkflowName "discover-crashed" - rotatedName = WorkflowName "discover-rotated" - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow completedName (WorkflowId "done") (demoWorkflow counter) - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt) - Left (_ :: SimulatedCrash) <- - try $ - Store.runStoreIO storeHandle $ - runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter) - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2) - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished - `shouldBe` [ ("crashed", "discover-crashed"), - ("rotated", "discover-rotated") - ] - - describe "Keiro.Workflow discovery index" $ around (withFreshStore fixture) $ do - -- The discovery predicate must be stated as the positive active set - -- (status IN ('running','suspended')) rather than as the complement of the - -- terminal trio: Postgres proves partial-index applicability from the query - -- predicate alone and never consults the table's CHECK constraint, so the - -- complement form cannot use keiro_workflows_active_idx and seq-scans - -- keiro_workflows on every resume pass. With seq scans discouraged, a plan - -- that names the index is proof the planner can match it. - it "plans the discovery predicate through keiro_workflows_active_idx" $ \storeHandle -> do - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle $ - Store.runTransaction $ - for_ (discoveryFixtureRows now) $ \row -> - Tx.statement row insertWorkflowInstanceStmt - Right planLines <- Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Tx.sql "SET LOCAL enable_seqscan = off" - Tx.statement () explainDiscoveryStmt - Text.unpack (Text.intercalate "\n" planLines) - `shouldSatisfy` isInfixOf "keiro_workflows_active_idx" - - -- Exact discovery: 'running' always, 'suspended' only with a due wake hint. - -- A suspended instance with no hint is parked on a wake source that will - -- flip the row itself, so returning it would be pure waste. - it "returns exactly the runnable and wake-due instances" $ \storeHandle -> do - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle $ - Store.runTransaction $ - for_ (discoveryFixtureRows now) $ \row -> - Tx.statement row insertWorkflowInstanceStmt - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished - `shouldBe` [ ("a-running", "discovery-index"), - ("c-due-sleep", "discovery-index") - ] - - describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do - it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - let opts = - defaultWorkflowRunOptions - & #snapshotPolicy - .~ Every 2 - & #metrics - ?~ keiroMetrics - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" - counter <- newIORef (0 :: Int) - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right journal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100 - Vector.length journal `shouldBe` 7 - Right snapshotVersionDuringFailure <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt - snapshotVersionDuringFailure `shouldBe` Nothing - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" - recoveryCounter <- newIORef (0 :: Int) - recovery <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter) - recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right snapshotVersionAfterRecovery <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt - snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6) - - -- Validation (a): a snapshot row appears at the expected version and - -- decodes to the full accumulated step map. - it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "snap" - wid = WorkflowId "w1" - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) - name - wid - (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6). - Right snapVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt - snapVersion `shouldBe` Just (StreamVersion 6) - -- and the row decodes to the six-entry accumulated map. - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1") - case mSeed of - Just (m, v) -> do - v `shouldBe` StreamVersion 6 - Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"] - Nothing -> expectationFailure "expected a workflow snapshot row" - - -- The OnTerminal completion-site wiring: only the final WorkflowCompleted - -- append (version 7) triggers the snapshot. - it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "term" - wid = WorkflowId "tm1" - result <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) - name - wid - (countingSixSteps counter) - result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right snapVersion <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt - snapVersion `shouldBe` Just (StreamVersion 7) - - -- Validation (b): re-hydration reads only the tail after the snapshot - -- version, and the journaled steps short-circuit (the counter stays put). - it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "tail" - wid = WorkflowId "t1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 - first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - afterFirst <- readIORef counter - afterFirst `shouldBe` 6 - -- A full version-0 replay would read every journal event... - Right full <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100 - Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted - -- ...whereas the runtime seeds from the snapshot and reads only the tail. - Right (Just (seedMap, StreamVersion sv)) <- - Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1") - Map.size seedMap `shouldBe` 6 - Right tailEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100 - Vector.length tailEvents `shouldSatisfy` (< Vector.length full) - Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7 - -- Re-hydration completes from the seed without re-running any step. - second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - afterSecond <- readIORef counter - afterSecond `shouldBe` 6 - - -- Validation (c): a Never run and an Every 2 run produce identical results - -- and identical journals, and the snapshot seed equals a full replay. - it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do - counterN <- newIORef (0 :: Int) - counterE <- newIORef (0 :: Int) - neverRes <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Never) - (WorkflowName "corr-never") - (WorkflowId "c1") - (countingSixSteps counterN) - everyRes <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) - (WorkflowName "corr-every") - (WorkflowId "c1") - (countingSixSteps counterE) - neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - Right neverEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100 - Right everyEvents <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100 - let stepResults evs = - [ (k, v) - | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs - ] - stepResults neverEvents `shouldBe` stepResults everyEvents - -- The snapshot seed equals the map a full version-0 replay would fold. - Right (Just (seedMap, _)) <- - Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1") - seedMap `shouldBe` Map.fromList (stepResults everyEvents) - - -- Validation (d): an advisory snapshot whose discriminant no longer matches - -- is ignored and the workflow hydrates via full replay. - it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "dmiss" - wid = WorkflowId "d1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 - _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1") - mSeed `shouldBe` Nothing - resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - - -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss. - it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do - (exporter, metricsRef) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - keiroMetrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "cjson" - wid = WorkflowId "d2" - opts = - defaultWorkflowRunOptions - & #snapshotPolicy - .~ Every 2 - & #metrics - ?~ keiroMetrics - _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt - Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2") - mSeed `shouldBe` Nothing - resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) - resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef metricsRef - let scalars = flattenScalarPoints exported - lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2) - - describe "Keiro.Workflow snapshot wake-safety" $ around (withFreshStore fixture) $ do - it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-unsignalled" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - first <- run - first `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - rowAfterFirst ^. #status `shouldBe` Awk.Pending - rowAfterFirst ^. #payload `shouldBe` Nothing - second <- run - second `shouldBe` Right Suspended - Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - rowAfterSecond ^. #status `shouldBe` Awk.Pending - rowAfterSecond ^. #payload `shouldBe` Nothing - - it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-midrun-awakeable" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable - armed <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - armed `shouldBe` Right Suspended - first <- run - first `shouldBe` Right (Completed "payload") - second <- run - second `shouldBe` Right (Completed "payload") - - it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "snapshot-stale-awakeable" - wid = WorkflowId "wf1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - armed <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) - armed `shouldBe` Right Suspended - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef) - first `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just (staleSeed, _)) <- - Store.runStoreIO storeHandle $ - loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) - staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid) - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo - second `shouldBe` Right (Completed "payload") - - it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do - let name = WorkflowName "snapshot-stale-child-parent" - wid = WorkflowId "wf1" - childWid = WorkflowId "child1" - opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid) - first `shouldBe` Right Suspended - Right (Just (staleSeed, _)) <- - Store.runStoreIO storeHandle $ - loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) - staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid) - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid) - second `shouldBe` Right (Completed "packed+labelled") - - describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do - -- M2: crash mid-run, then a resume pass drives the workflow to Completed - -- without re-running the already-journaled step. - it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "crash-demo" - wid = WorkflowId "cd-1" - -- Simulate a crash after step 1's append has committed. - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (crashAfterStep1 counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () -- the SimulatedCrash unwound the run, as intended - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - readIORef counter >>= \c -> c `shouldBe` 1 - -- Resume with a registry mapping the name to the FULL definition. - let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` ResumeSummary - { discovered = 1, - advanced = 1, - resumed = 1, - completed = 1, - stillSuspended = 0, - unknownName = 0, - failed = 0, - transientErrors = 0, - leaseSkipped = 0, - paced = 0, - sleepDue = 0, - unregisteredNames = Set.empty - } - -- Step 1 short-circuited; steps 2 and 3 ran exactly once. - readIORef counter >>= \c -> c `shouldBe` 3 - -- The journal now holds s1, s2, s3, WorkflowCompleted. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True - _ -> False - -- A second pass discovers nothing — the workflow is finished. - Right summary2 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary2 `shouldBe` emptyResumeSummary - - -- M3: a workflow suspended on an awaited step is driven to Completed once - -- that step is journaled (here simulated; an EP-39/EP-40 wake source would - -- journal the same StepRecorded end to end). - it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "await-demo" - wid = WorkflowId "ad-1" - suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter) - suspended `shouldBe` Right Suspended - -- Simulate the wake source resolving the await. - Right () <- Store.runStoreIO storeHandle $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now) - let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter)) - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` ResumeSummary - { discovered = 1, - advanced = 1, - resumed = 1, - completed = 1, - stillSuspended = 0, - unknownName = 0, - failed = 0, - transientErrors = 0, - leaseSkipped = 0, - paced = 0, - sleepDue = 0, - unregisteredNames = Set.empty - } - readIORef counter >>= \c -> c `shouldBe` 1 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True - _ -> False - - -- M4: a discovered workflow whose name is absent from the registry is - -- skipped and counted, never silently dropped or fatal. - it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "orphan" - wid = WorkflowId "or-1" - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (crashAfterStep1 counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - -- Empty registry: the orphan is surfaced via unknownName, not completed. - Right summary <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty - summary - `shouldBe` ResumeSummary - { discovered = 1, - advanced = 0, - resumed = 0, - completed = 0, - stillSuspended = 0, - unknownName = 1, - failed = 0, - transientErrors = 0, - leaseSkipped = 0, - paced = 0, - sleepDue = 0, - unregisteredNames = Set.singleton "orphan" - } - -- The journal is unchanged: still one step, no completion. - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10 - Vector.length recorded `shouldBe` 1 - - it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do - healthyCounter <- newIORef (0 :: Int) - let poisonName = WorkflowName "poison" - poisonId = WorkflowId "poison-1" - healthyName = WorkflowName "healthy" - healthyId = WorkflowId "healthy-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = - Map.fromList - [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), - (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - summary - `shouldBe` emptyResumeSummary - { discovered = 2, - advanced = 2, - resumed = 2, - completed = 1, - failed = 1 - } - readIORef healthyCounter >>= \c -> c `shouldBe` 3 - Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId - poisonRow ^. #status `shouldBe` Instance.WfFailed - - -- Concurrency is opt-in and observable. Two workflows whose step actions - -- take ~300 ms run in overlapping windows under `maxConcurrentAdvances = 2` - -- and in disjoint windows under the default, so one slow step body no - -- longer delays every other workflow in the pass. - it "advances candidates concurrently only when the option allows it" $ \storeHandle -> do - let slowStep windows label = do - start <- liftIO getCurrentTime - liftIO (threadDelay 300_000) - end <- liftIO getCurrentTime - liftIO (modifyMVar windows (\ws -> pure ((label, start, end) : ws, ()))) - pure (1 :: Int) - runPass concurrency prefix = do - windows <- newMVar [] - let nameA = WorkflowName (prefix <> "-a") - nameB = WorkflowName (prefix <> "-b") - widA = WorkflowId (prefix <> "-1") - widB = WorkflowId (prefix <> "-2") - opts = - defaultWorkflowResumeOptions - & #maxConcurrentAdvances - .~ concurrency - & #logEvent - .~ const (pure ()) - registry = - Map.fromList - [ (nameA, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows ("a" :: Text)))), - (nameB, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows "b"))) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry nameA widA (StepRecorded "seed" (toJSON True) now) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry nameB widB (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - completed summary `shouldBe` 2 - readMVar windows - concurrentWindows <- runPass 2 "overlap" - windowsOverlap concurrentWindows `shouldBe` True - serialWindows <- runPass 1 "serial" - windowsOverlap serialWindows `shouldBe` False - - -- Concurrency must not change what a pass reports or how it isolates a bad - -- candidate: the deltas are added at the end, so the summary cannot depend - -- on the order candidates finish in. Each phase runs against its own fresh - -- store, because an unknown-name candidate stays discoverable and would - -- otherwise carry into the next phase's counts. - it "reports a mixed pass the same way when advancing sequentially" $ \storeHandle -> do - summary <- runMixedResumePass storeHandle 1 - summary `shouldBe` expectedMixedResumeSummary - - it "reports a mixed pass the same way when advancing concurrently" $ \storeHandle -> do - summary <- runMixedResumePass storeHandle 3 - summary `shouldBe` expectedMixedResumeSummary - - it "records no crash attempt against a workflow that already went terminal" $ \storeHandle -> do - let name = WorkflowName "crash-race" - wid = WorkflowId "cr-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - -- A live instance paces normally. - Right live <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Instance.recordCrashTx "cr-1" "crash-race" "boom" - live `shouldBe` Just 1 - -- Once terminal, the UPDATE's status guard matches no row. That is the - -- answer, not an error: there is no live instance left to pace. - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (WorkflowCancelled cancelledAt) - Right afterTerminal <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Instance.recordCrashTx "cr-1" "crash-race" "boom" - afterTerminal `shouldBe` Nothing - - -- The race the arm above exists for. Workflow A goes terminal inside its own - -- run and then crashes, so the pass records its crash against a cancelled - -- instance. The zero-row result used to fail a single-row decoder, and - -- because the crash record sits outside the per-advance catches, the store - -- error escaped the whole pass: `resumeWorkflowsOnce` returned Left and - -- every remaining candidate was skipped until the next tick. - it "survives a crash recorded against a just-cancelled workflow" $ \storeHandle -> do - healthyCounter <- newIORef (0 :: Int) - events <- newIORef ([] :: [ResumeLogEvent]) - let raceName = WorkflowName "crash-race-pass" - raceId = WorkflowId "crp-1" - healthyName = WorkflowName "crash-race-healthy" - healthyId = WorkflowId "crh-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ (\event -> modifyIORef' events (event :)) - registry = - Map.fromList - [ ( raceName, - WorkflowDef - ( \_ -> do - cancelledAt <- liftIO getCurrentTime - appendJournalEntry raceName raceId (WorkflowCancelled cancelledAt) - liftIO (throwIO SimulatedCrash) *> pure (0 :: Int) - ) - ), - (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry raceName raceId (StepRecorded "seed" (toJSON True) now) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry healthyName healthyId (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - summary - `shouldBe` emptyResumeSummary - { discovered = 2, - advanced = 1, - resumed = 2, - completed = 1, - transientErrors = 1 - } - -- The healthy workflow ran to completion regardless of which candidate - -- discovery returned first, and nothing was marked failed: a workflow that - -- is already cancelled must not also be condemned. - readIORef healthyCounter `shouldReturn` 3 - logged <- readIORef events - logged `shouldContain` [ResumeCrashRecordSkipped "crash-race-pass" "crp-1"] - Right (Just raceRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance raceName raceId - raceRow ^. #status `shouldBe` Instance.WfCancelled - raceRow ^. #attempts `shouldBe` 0 - - it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do - let name = WorkflowName "terminal-poison" - wid = WorkflowId "tp-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfFailed - row ^. #attempts `shouldBe` 1 - direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int))) - direct `shouldBe` Right Failed - Right recordedFailed <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed) - `shouldSatisfy` \case - Right events -> any (\case WorkflowFailed {} -> True; _ -> False) events - _ -> False - - it "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do - shouldCrash <- newIORef True - counter <- newIORef (0 :: Int) - let name = WorkflowName "resurrect-complete" - wid = WorkflowId "rc-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (recoverableWorkflow shouldCrash counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - readIORef counter `shouldReturn` 1 - - Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed failedPass `shouldBe` 1 - Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - failedRow ^. #status `shouldBe` Instance.WfFailed - - writeIORef shouldCrash False - resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - resurrected `shouldBe` Right Instance.WorkflowResurrected - Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - revivedRow ^. #status `shouldBe` Instance.WfRunning - revivedRow ^. #attempts `shouldBe` 0 - revivedRow ^. #lastError `shouldBe` Nothing - revivedRow ^. #nextAttemptAt `shouldBe` Nothing - - Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - completed completedPass `shouldBe` 1 - readIORef counter `shouldReturn` 2 - Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - completedRow ^. #status `shouldBe` Instance.WfCompleted - - it "can fail again in the same generation after resurrection" $ \storeHandle -> do - shouldCrash <- newIORef True - counter <- newIORef (0 :: Int) - let name = WorkflowName "resurrect-refail" - wid = WorkflowId "rr-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow name wid (recoverableWorkflow shouldCrash counter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - - Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed firstFailedPass `shouldBe` 1 - firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - firstRevival `shouldBe` Right Instance.WorkflowResurrected - Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed secondFailedPass `shouldBe` 1 - Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - refailedRow ^. #status `shouldBe` Instance.WfFailed - - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward - (workflowGenerationStreamName name wid 0) - (StreamVersion 0) - 10 - let failureIds = - [ event ^. #eventId - | event <- Vector.toList recorded, - Right decoded <- [decodeRecorded workflowJournalCodec event], - WorkflowFailed {} <- [decoded] - ] - case failureIds of - [firstFailureId, secondFailureId] -> - firstFailureId `shouldNotBe` secondFailureId - other -> - expectationFailure ("expected two failure events, got " <> show other) - - secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - secondRevival `shouldBe` Right Instance.WorkflowResurrected - - it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do - let runningName = WorkflowName "resurrect-running" - runningId = WorkflowId "running-1" - missingName = WorkflowName "resurrect-missing" - missingId = WorkflowId "missing-1" - childName = WorkflowName "resurrect-child" - childId = WorkflowId "child-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now) - runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId - runningOutcome `shouldBe` Right Instance.WorkflowNotFailed - missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId - missingOutcome `shouldBe` Right Instance.WorkflowNotFound - - Right childMarkedFailed <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Child.registerChildTx - "child-1" - "resurrect-child" - "parent-1" - "resurrect-parent" - "child:child-1:result" - Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure" - childMarkedFailed `shouldBe` True - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now) - - childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId - childOutcome `shouldBe` Right Instance.WorkflowResurrected - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child" - childRow ^. #status `shouldBe` Child.Running - childRow ^. #result `shouldBe` Nothing - childRow ^. #failureReason `shouldBe` Nothing - childRow ^. #completedAt `shouldBe` Nothing - - it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do - let name = WorkflowName "transient" - wid = WorkflowId "tr-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = - Map.singleton name $ - WorkflowDef - ( \_ -> do - _ <- throwError (Store.ConnectionLost "boom") - pure (0 :: Int) - ) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - transientErrors summary `shouldBe` 1 - failed summary `shouldBe` 0 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #attempts `shouldBe` 0 - row ^. #status `shouldBe` Instance.WfRunning - - it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do - done <- newEmptyMVar - healthyCounter <- newIORef (0 :: Int) - let poisonName = WorkflowName "fixed-loop-poison" - poisonId = WorkflowId "flp-1" - healthyName = WorkflowName "fixed-loop-healthy" - healthyId = WorkflowId "flh-1" - opts = - defaultWorkflowResumeOptions - & #pollInterval - .~ 50_000 - & #maxAttempts - .~ 1 - & #logEvent - .~ const (pure ()) - healthyBody = threeStepThenSignal healthyCounter done - registry = - Map.fromList - [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), - (healthyName, WorkflowDef (\_ -> healthyBody)) - ] - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) - crashed <- - try - ( Store.runStoreIO storeHandle $ - runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) - ) :: - IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) - case crashed of - Left _ -> pure () - Right other -> expectationFailure ("expected a simulated crash, got " <> show other) - worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry))) - completed <- timeout 5_000_000 (takeMVar done) - status <- threadStatus worker - killThread worker - completed `shouldBe` Just () - status `shouldSatisfy` \case - ThreadFinished -> False - ThreadDied -> False - _ -> True - - it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do - let name = WorkflowName "lease-claim" - wid = WorkflowId "lc-1" - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid - claimedA `shouldBe` Instance.ClaimAcquired - Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedB `shouldBe` Instance.ClaimLeaseHeld - Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid - Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedBAfterRelease `shouldBe` Instance.ClaimAcquired - - it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do - let name = WorkflowName "lease-expire" - wid = WorkflowId "le-1" - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid - claimedA `shouldBe` Instance.ClaimAcquired - Right attempt <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Instance.recordCrashTx "le-1" "lease-expire" "boom" - attempt `shouldBe` Just 1 - Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid - Right pacedClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - pacedClaim `shouldBe` Instance.ClaimPaced - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'" - Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid - claimedB `shouldBe` Instance.ClaimAcquired - Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #attempts `shouldBe` 0 - row ^. #lastError `shouldBe` Nothing - row ^. #nextAttemptAt `shouldBe` Nothing - row ^. #leasedBy `shouldBe` Nothing - - it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do - ran <- newIORef False - let name = WorkflowName "lease-skip" - wid = WorkflowId "ls-1" - registry = - Map.singleton name $ - WorkflowDef - ( \_ -> do - liftIO (writeIORef ran True) - pure (0 :: Int) - ) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) - Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid - foreignClaim `shouldBe` Instance.ClaimAcquired - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary - `shouldBe` emptyResumeSummary - { discovered = 1, - leaseSkipped = 1 - } - readIORef ran `shouldReturn` False - - -- M4: resume on an already-completed workflow is a genuine no-op. - it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "done-demo" - wid = WorkflowId "dd-1" - done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter) - done `shouldBe` Right (Completed (1, 2, 3)) - readIORef counter >>= \c -> c `shouldBe` 3 - let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) - Right summary1 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary1 `shouldBe` emptyResumeSummary - Right summary2 <- - Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry - summary2 `shouldBe` emptyResumeSummary - readIORef counter >>= \c -> c `shouldBe` 3 - - describe "Keiro.Workflow lease renewal" $ around (withFreshStore fixture) $ do - it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do - attemptedClaim <- newIORef Nothing - let name = WorkflowName "lease-heartbeat" - wid = WorkflowId "heartbeat-1" - runOpts = - defaultWorkflowRunOptions - & #leaseHeartbeat - .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} - body = - step (StepName "slow-boundary") $ do - liftIO (threadDelay 300_000) - claimed <- - Instance.claimInstance - "owner-b" - 60 - name - wid - liftIO (writeIORef attemptedClaim (Just claimed)) - pure (claimed == Instance.ClaimAcquired) - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid - claimedA `shouldBe` Instance.ClaimAcquired - outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body - outcome `shouldBe` Right (Completed False) - readIORef attemptedClaim `shouldReturn` Just Instance.ClaimLeaseHeld - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #leasedBy `shouldBe` Just "owner-a" - - it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do - let directName = WorkflowName "lease-lost-direct" - directId = WorkflowId "lost-direct-1" - directOpts = - defaultWorkflowRunOptions - & #leaseHeartbeat - .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now) - Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId - claimedA `shouldBe` Instance.ClaimAcquired - leaseUntil <- addUTCTime 60 <$> getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement - ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil) - forceWorkflowLeaseStmt - firstDirectEffect <- newIORef (0 :: Int) - secondDirectEffect <- newIORef (0 :: Int) - direct <- - try - ( Store.runStoreIO storeHandle $ - runWorkflowWith directOpts directName directId $ do - _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect)) - step (StepName "second") (liftIO (incrementAndRead secondDirectEffect)) - ) :: - IO - ( Either - WorkflowLeaseLost - (Either Store.StoreError (WorkflowOutcome Int)) - ) - direct `shouldBe` Left WorkflowLeaseLost - readIORef firstDirectEffect `shouldReturn` 0 - readIORef secondDirectEffect `shouldReturn` 0 - directFinishedAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry directName directId (WorkflowCompleted directFinishedAt) - - firstWorkerEffect <- newIORef (0 :: Int) - secondWorkerEffect <- newIORef (0 :: Int) - let workerName = WorkflowName "lease-lost-worker" - workerId = WorkflowId "lost-worker-1" - workerOpts = - defaultWorkflowResumeOptions - & #logEvent - .~ const (pure ()) - registry = - Map.singleton workerName $ - WorkflowDef $ \_ -> do - _ <- - step (StepName "first") $ do - value <- liftIO (incrementAndRead firstWorkerEffect) - expires <- liftIO (addUTCTime 60 <$> getCurrentTime) - Store.runTransaction $ - Tx.statement - ("lost-worker-1", "lease-lost-worker", "owner-b", expires) - forceWorkflowLeaseStmt - pure value - step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect)) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry - summary - `shouldBe` emptyResumeSummary - { discovered = 1, - leaseSkipped = 1 - } - readIORef firstWorkerEffect `shouldReturn` 1 - readIORef secondWorkerEffect `shouldReturn` 0 - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId - row ^. #attempts `shouldBe` 0 - row ^. #leasedBy `shouldBe` Just "owner-b" - - describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do - -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that - -- rotates every 50 steps keeps each physical generation journal bounded by - -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that - -- opened the generation + the one terminal marker), yet returns the correct - -- final total. A single non-rotating run would put all 300 steps on one - -- journal and the per-generation `<= K` bound would fail. - it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "roller" - wid = WorkflowId "r-1" - rotateEvery = 50 :: Int - total = 300 :: Int - k = rotateEvery + 2 - body = rollingTotal counter rotateEvery total - -- Re-invoke runWorkflow until it Completes; each call resolves and - -- advances the current generation, exactly as the resume worker does. - drive :: Int -> IO Int - drive budget - | budget <= 0 = - expectationFailure "workflow did not complete within the rotation budget" >> pure (-1) - | otherwise = do - outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) - case outcome of - Right ContinuedAsNew -> drive (budget - 1) - Right (Completed t) -> pure t - other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1) - -- The first invocation rotates (generation 0 did rotateEvery steps). - firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) - firstOutcome `shouldBe` Right ContinuedAsNew - -- Drive the remaining generations to completion (bounded passes). - finalTotal <- drive (total `div` rotateEvery + 3) - -- Check 2: correct result, and each side effect ran exactly once. - finalTotal `shouldBe` total - readIORef counter >>= (`shouldBe` total) - -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5). - Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid) - gen `shouldBe` (total `div` rotateEvery - 1) - -- Check 1: every generation's physical journal is bounded by K, and the - -- total is split ACROSS generations (bounded per generation, not in - -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1 - -- marker = K events, so the sum is total + 2 per generation. - lengths <- - traverse - ( \g -> do - let streamName = workflowGenerationStreamName name wid g - Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000) - pure (Vector.length evs) - ) - [0 .. gen] - for_ lengths (`shouldSatisfy` (<= k)) - sum lengths `shouldBe` (total + 2 * (gen + 1)) - -- The first generation ends with a rotation marker; the last with a - -- completion marker. - Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000) - (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs) - `shouldSatisfy` any - ( \case - Right (WorkflowContinuedAsNew 1 _) -> True - _ -> False - ) - Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000) - (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs) - `shouldSatisfy` any - ( \case - Right (WorkflowCompleted _) -> True - _ -> False - ) - - -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a - -- rotation the rotated (newer) generation is unfinished and discoverable — - -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and - -- the resume worker drives the rotated generation forward to completion. - it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "roller2" - wid = WorkflowId "r-2" - rotateEvery = 50 :: Int - total = 150 :: Int - registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total)) - resumeUntilDone :: Int -> IO () - resumeUntilDone budget - | budget <= 0 = expectationFailure "resume did not complete the rotated workflow" - | otherwise = do - Right summary <- - Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - if completed summary == 1 then pure () else resumeUntilDone (budget - 1) - -- First run rotates onto generation 1. - firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total)) - firstOutcome `shouldBe` Right ContinuedAsNew - -- The rotated current generation (1) is unfinished and discoverable. - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished `shouldBe` [("r-2", "roller2")] - -- The resume worker drives the rotated generation(s) to completion. - resumeUntilDone (total `div` rotateEvery + 3) - readIORef counter >>= (`shouldBe` total) - -- Finished: discovery now reports nothing for it. - finalNow <- getCurrentTime - Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow) - finalUnfinished `shouldBe` [] - - describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do - it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "patchwf" - inflight = WorkflowId "inflight-1" - fresh = WorkflowId "fresh-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - - -- 1. Run the in-flight instance to a suspension under the PRE-patch code. - pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter) - pre `shouldBe` Right Suspended - - -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It - -- already journaled reserve-inventory, so it is in flight -> False. - r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) - r1 `shouldBe` Right (Completed "old-branch") - - -- 3. Replay the in-flight instance again: same OLD branch, every time. - r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) - r2 `shouldBe` Right (Completed "old-branch") - - -- 4. A fresh instance under the POST-patch code takes the NEW branch. - f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) - f1 `shouldBe` Right (Completed "new-branch") - -- and stays on the new branch on replay. - f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) - f2 `shouldBe` Right (Completed "new-branch") - - -- 5. The patch decision is journaled exactly once per instance, with the - -- expected Bool, on the patch: key. - Right inflightJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20 - let inflightDecisions = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal), - StepRecorded k v _ <- [ev], - k == patchStepName fraudPatchId - ] - inflightDecisions `shouldBe` [toJSON False] - - Right freshJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20 - let freshDecisions = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), - StepRecorded k v _ <- [ev], - k == patchStepName fraudPatchId - ] - freshDecisions `shouldBe` [toJSON True] - let freshPatchSets = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), - StepRecorded k v _ <- [ev], - k == patchSetStepName - ] - freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - - it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "patch-after-suspend" - wid = WorkflowId "pas-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) - resumed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) - resumed `shouldBe` Right (Completed "new-branch") - - it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do - let name = WorkflowName "patch-wake-only" - wid = WorkflowId "pwo-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) - resumed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow - resumed `shouldBe` Right (Completed "old-branch") - - it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do - let name = WorkflowName "patch-rotating" - wid = WorkflowId "pr-1" - patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId - first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow - first `shouldBe` Right ContinuedAsNew - second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow - second `shouldBe` Right (Completed "new-branch") - Right gen1Journal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20 - let gen1PatchSets = - [ v - | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal), - StepRecorded k v _ <- [ev], - k == patchSetStepName - ] - gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - - describe "Keiro.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do - it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do - let name = WorkflowName "patch-rotation-race" - wid = WorkflowId "prr-1" - patchOptions = - defaultWorkflowRunOptions - & #activePatches - .~ Set.singleton fraudPatchId - generationOneStream = workflowGenerationStreamName name wid 1 - - first <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - first `shouldBe` Right ContinuedAsNew - Right patchSetRecorded <- - Store.runStoreIO storeHandle $ - stepExists name wid 1 patchSetStepName - patchSetRecorded `shouldBe` True - - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry - name - wid - ( StepRecorded - "awk:11111111-1111-1111-1111-111111111111" - (toJSON True) - now - ) - - second <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - second `shouldBe` Right (Completed "new-branch") - replayed <- - Store.runStoreIO storeHandle $ - runWorkflowWith patchOptions name wid rotatingPatchWorkflow - replayed `shouldBe` Right (Completed "new-branch") - - Right generationOneJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward generationOneStream (StreamVersion 0) 20 - let decoded = - map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal) - patchSets = - [ value - | Right (StepRecorded key value _) <- decoded, - key == patchSetStepName - ] - decisions = - [ value - | Right (StepRecorded key value _) <- decoded, - key == patchStepName fraudPatchId - ] - patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] - decisions `shouldBe` [toJSON True] - - describe "Keiro.Wake" $ around (withFreshStore fixture) $ do - -- EP-50: the wake primitive over kiroku's existing per-store notifier. - it "returns WokenByTimeout when idle (no append)" $ \store -> do - wake <- wakeSignalFromStore store - reason <- waitForWake wake 200000 -- 200 ms - reason `shouldBe` WokenByTimeout - - it "returns WokenByNotify promptly after a real append" $ \store -> do - wake <- wakeSignalFromStore store - -- A real append bumps the streams row and fires kiroku's NOTIFY on - -- kiroku.events; the store's notifier ticks the broadcast channel. - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now) - reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds - reason `shouldBe` WokenByNotify - - it "neverWake always returns WokenByTimeout" $ \_store -> do - reason <- waitForWake neverWake 100000 - reason `shouldBe` WokenByTimeout - - describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do - -- The user-visible win: a gated workflow resumes within sub-second of the - -- gate append, under a deliberately large (10 s) fallback — so a pass that - -- resumes it sub-second can only have been woken by the NOTIFY, not the poll. - it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do - done <- newEmptyMVar - let name = WorkflowName "pushwf" - wid = WorkflowId "p-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) - -- Let the worker start, duplicate the tick channel, and park in its wait - -- before we append, so the gate's NOTIFY cannot be missed. - threadDelay 250000 - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5000000 (takeMVar done) - t1 <- getCurrentTime - killThread worker - resumed `shouldBe` Just () - let latency = realToFrac (diffUTCTime t1 now) :: Double - latency `shouldSatisfy` (< 1.0) - - it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do - done <- newEmptyMVar - logs <- newIORef [] - let name = WorkflowName "push-recover" - wid = WorkflowId "pr-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - opts = - defaultWorkflowResumeOptions - & #pollInterval - .~ 100_000 - & #logEvent - .~ \event -> modifyIORef' logs (<> [event]) - waitForPassFailure = timeout 5_000_000 $ do - let go = do - seen <- readIORef logs - if any isPassFailure seen - then pure () - else threadDelay 20_000 >> go - go - isPassFailure = \case - ResumePassFailed {} -> True - _ -> False - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - -- Break the table discovery itself reads, so every pass fails outright. - -- (Hiding keiro_workflow_steps no longer suffices: under exact discovery - -- the parked workflow is not returned, so a pass never reaches it.) - Right () <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_workflows RENAME TO keiro_workflows_hidden" - worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) - logged <- waitForPassFailure - logged `shouldBe` Just () - Right () <- - Store.runStoreIO store $ - Store.runTransaction $ - Tx.sql "ALTER TABLE keiro.keiro_workflows_hidden RENAME TO keiro_workflows" - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5_000_000 (takeMVar done) - status <- threadStatus worker - killThread worker - resumed `shouldBe` Just () - status `shouldSatisfy` \case - ThreadFinished -> False - ThreadDied -> False - _ -> True - - describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do - -- Push is strictly an optimization: with the worker on 'neverWake' (every - -- NOTIFY dropped) and a small fallback, the gated workflow still drains on - -- the durable poll. - it "still drains on the fallback timeout when no notification is delivered" $ \store -> do - done <- newEmptyMVar - let name = WorkflowName "fallbackwf" - wid = WorkflowId "f-1" - registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) - onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)) - first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) - first `shouldBe` Right Suspended - worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications - now <- getCurrentTime - Right () <- - Store.runStoreIO store $ - appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) - resumed <- timeout 5000000 (takeMVar done) - killThread worker - resumed `shouldBe` Just () - - describe "Shard lease" $ around (withFreshStore fixture) $ do - -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit - -- `now` timestamps standing in for the passage of time (no workers yet). The - -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and - -- failover are both observable purely from the lease table. - let subName = SubscriptionName "orders-shard" - wA = WorkerId sampleUuid - wB = WorkerId sampleUuid2 - ttl = 30 :: NominalDiffTime - t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - tExpired = addUTCTime 60 t0 -- past A's 30 s lease - shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4 - it "validates sharded worker options before startup" $ \_store -> do - shouldBeRight_ (mkShardedWorkerOptions shardOpts) - mkShardedWorkerOptions (shardOpts & #shardCount .~ 0) - `shouldBeLeft` InvalidShardCount 0 - mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0) - `shouldBeLeft` InvalidShardLeaseTtl 0 - mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0) - `shouldBeLeft` InvalidShardRenewInterval 0 - mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10) - `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10 - mkShardedWorkerOptions (shardOpts & #batchSize .~ 0) - `shouldBeLeft` InvalidShardBatchSize 0 - mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0) - `shouldBeLeft` InvalidShardBufferSize 0 - mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1)) - `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1)) - mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0) - `shouldBeLeft` InvalidShardRetryMaxAttempts 0 - - it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - ensureShardRows subName 4 - Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName) - map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3] - all (\(_, o, _) -> isNothing o) rows `shouldBe` True - - it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do - Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - claimShardsTx subName wA 4 t0 ttl - claimedA `shouldBe` [0, 1, 2, 3] - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) - claimedB `shouldBe` [] - - it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do - Right _ <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - claimShardsTx subName wA 4 t0 ttl - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl) - claimedB `shouldBe` [0, 1, 2, 3] - -- A lost every bucket to B, so its renew returns the empty set: this is how - -- a worker learns it no longer owns a bucket and stops reading it. - Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl) - heldA `shouldBe` [] - - it "renewLease returns only still-held buckets" $ \store -> do - Right held <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - _ <- claimShardsTx subName wA 4 t0 ttl - renewLeaseTx subName wA t0 ttl - held `shouldBe` [0, 1, 2, 3] - - it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do - Right _ <- Store.runStoreIO store $ Store.runTransaction $ do - ensureShardRows subName 4 - _ <- claimShardsTx subName wA 4 t0 ttl - releaseShardsTx subName wA [0, 1] - -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable. - Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) - claimedB `shouldBe` [0, 1] - - it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do - fairShareTarget 6 3 `shouldBe` 2 - fairShareTarget 6 4 `shouldBe` 2 - fairShareTarget 7 3 `shouldBe` 3 - fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything - it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do - let previous = Set.fromList [0, 2] - acquireOutcome previous (Left "database unavailable") - `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable")) - acquireOutcome previous (Right (Set.fromList [1, 3])) - `shouldBe` (Set.fromList [1, 3], Nothing) - - it "ensureShards rejects a shardCount mismatch" $ \store -> do - let lease4 = - ShardLease - { subscriptionName = subName, - workerId = wA, - shardCount = 4, - leaseTtl = ttl - } - lease6 = - ShardLease - { subscriptionName = subName, - workerId = wA, - shardCount = 6, - leaseTtl = ttl - } - Right () <- Store.runStoreIO store (ensureShards lease4) - Store.runStoreIO store (ensureShards lease6) - `shouldThrow` \case - ShardCountMismatch name configured found -> - name == "orders-shard" && configured == 6 && found == [4] - - describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do - -- EP-51 M3: one process owning all N buckets drains a seeded category exactly - -- once. The sink is idempotent on event_id, so "count == total" proves every - -- event was delivered with none missing and none surviving as a duplicate row. - it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 8 5 -- 40 events across 8 streams - let opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 3, - renewInterval = 0.3 - } - w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1)) - drained <- waitUntilSinkCount store total 20_000_000 - killThread w - drained `shouldBe` True - count <- shardSinkCount store - count `shouldBe` total - maxW <- maxWorkersPerStream store - maxW `shouldBe` 1 - - describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do - -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively - -- partition a category; we let ownership converge on the *empty* category - -- first (so the churn of cold-start rebalancing touches no events), then seed - -- and drain under stable membership — so each stream is owned by exactly one - -- worker throughout the drain. Then we kill a worker and prove its buckets are - -- re-homed and the new events drain (failover via lease expiry). - let sub = SubscriptionName "orders-failover" - mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6) {leaseTtl = 3, renewInterval = 0.3} - it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1)) - w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2)) - w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3)) - -- Wait for cooperative balance on the empty category: all 6 buckets owned, - -- spread across >= 2 workers, none holding more than its fair share. - balanced <- waitShardsBalanced store sub 6 2 15_000_000 - balanced `shouldBe` True - -- Now seed and drain under stable membership. - total1 <- seedOrders store 12 5 -- 60 events - ok1 <- waitUntilSinkCount store total1 25_000_000 - ok1 `shouldBe` True - -- Disjoint: no stream key was processed by two workers (stable membership, - -- so no re-homing split any stream). - maxW <- maxWorkersPerStream store - maxW `shouldBe` 1 - -- The work genuinely spread (not a monopoly): at least two workers participated. - spread <- distinctWorkers store - spread `shouldSatisfy` (>= 2) - -- Counts sum to total with no duplicate event id (PK on event_id + count). - c1 <- shardSinkCount store - c1 `shouldBe` total1 - -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire). - killThread w1 - -- Seed more across all streams; some hash to worker 1's now-orphaned buckets. - total2 <- seedOrders store 12 5 -- another 60 - -- Failover: a surviving worker re-claims the expired buckets and drains the - -- new events. If re-homing did not happen, events on worker 1's buckets would - -- never drain and this would time out. - ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000 - killThread w2 - killThread w3 - ok2 `shouldBe` True - c2 <- shardSinkCount store - c2 `shouldBe` (total1 + total2) - - it "a killed worker relinquishes its leases immediately" $ \store -> do - let subImmediate = SubscriptionName "orders-immediate-release" - longTtlOpts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 30, - renewInterval = 0.2 - } - w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1)) - owned <- waitShardsBalanced store subImmediate 4 1 10_000_000 - owned `shouldBe` True - killThread w - released <- waitShardsUnowned store subImmediate 4 3_000_000 - released `shouldBe` True - - it "a handler exception is retried in place and drains" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - thrown <- newIORef False - errors <- newIORef [] - let subRestart = SubscriptionName "orders-reader-restart" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2) - { leaseTtl = 3, - renewInterval = 0.2, - handlerRetryDelay = KirokuSub.RetryDelay 0.05, - onShardError = Just (\err -> modifyIORef' errors (err :)) - } - handler ev = do - firstTime <- - atomicModifyIORef' - thrown - ( \seen -> - if seen - then (seen, False) - else (True, True) - ) - when firstTime (throwIO (userError "reader boom")) - sinkHandler store 1 ev - w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler) - balanced <- waitShardsBalanced store subRestart 2 1 10_000_000 - balanced `shouldBe` True - total <- seedOrders store 4 2 - drained <- waitUntilSinkCount store total 20_000_000 - killThread w - drained `shouldBe` True - seenErrors <- readIORef errors - seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) - - describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do - it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 5 - enteredTail <- newEmptyMVar - holdTail <- newEmptyMVar - let sub = SubscriptionName "orders-ack-tail" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 3, - renewInterval = 0.3 - } - blockingHandler ev = do - let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) - when (orderNumber == Right (4 :: Int)) $ do - putMVar enteredTail () - takeMVar holdTail - sinkHandler store 1 ev - first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler) - entered <- timeout 10_000_000 (takeMVar enteredTail) - entered `shouldBe` Just () - -- The old pull bridge replies Continue before invoking the handler; - -- leave enough time for its batch-tail checkpoint to commit while the - -- handler remains blocked. The ack-coupled bridge introduced by EP-96 - -- remains blocked on the unfilled reply instead. - threadDelay 200_000 - killThread first - second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2)) - drained <- waitUntilSinkCount store total 20_000_000 - killThread second - drained `shouldBe` True - shardSinkCount store `shouldReturn` total - - it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 24 5 - let sub = SubscriptionName "orders-ack-rebalance" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) - { leaseTtl = 3, - renewInterval = 0.3, - batchSize = 1 - } - slowHandler tag ev = do - threadDelay 100_000 - sinkHandler store tag ev - first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1)) - -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner - -- while A owns three leaves one claimable bucket for B, making B visible; - -- A's next pass then sheds its excess third bucket while its handler is - -- deliberately slow and in flight. - ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000 - ownsThree `shouldBe` True - second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2)) - drained <- waitUntilSinkCount store total 30_000_000 - killThread first - killThread second - drained `shouldBe` True - shardSinkCount store `shouldReturn` total - - it "allows zombie overlap duplicates without losing an event" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 5 - entered <- newEmptyMVar - release <- newEmptyMVar - deliveries <- newIORef ([] :: [EventId]) - successor <- newIORef Nothing - readersA <- newIORef Map.empty - let sub = SubscriptionName "orders-ack-zombie" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 2, - renewInterval = 0.2 - } - leaseA = - ShardLease - { subscriptionName = sub, - workerId = WorkerId sampleUuid, - shardCount = 1, - leaseTtl = 2 - } - handlerA delivery = do - let ev = delivery ^. #event - modifyIORef' deliveries ((ev ^. #eventId) :) - putMVar entered () - takeMVar release - sinkHandler store 1 ev - pure ShardAckOk - handlerB delivery = do - let ev = delivery ^. #event - modifyIORef' deliveries ((ev ^. #eventId) :) - sinkHandler store 2 ev - pure ShardAckOk - cleanup = do - void (tryPutMVar release ()) - mSuccessor <- readIORef successor - for_ mSuccessor killThread - now <- getCurrentTime - let cleanupWorker = WorkerId sampleUuid2 - _ <- Store.runStoreIO store $ Store.runTransaction $ do - releaseShardsTx sub (WorkerId sampleUuid) [0] - claimShardsTx sub cleanupWorker 1 now 30 - void (reconcileShardsOnce store leaseA opts readersA handlerA) - ( do - Right () <- Store.runStoreIO store (ensureShards leaseA) - void (reconcileShardsOnce store leaseA opts readersA handlerA) - timeout 10_000_000 (takeMVar entered) `shouldReturn` Just () - -- A no longer renews, but its reader remains alive and blocked - -- with one unacknowledged event. B can claim after expiry and - -- must therefore receive that event again from the checkpoint. - threadDelay 2_500_000 - workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB) - writeIORef successor (Just workerB) - drained <- waitUntilSinkCount store total 20_000_000 - drained `shouldBe` True - raw <- readIORef deliveries - length raw `shouldSatisfy` (> total) - shardSinkCount store `shouldReturn` total - ) - `finally` cleanup - - it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do - Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) - total <- seedOrders store 1 4 - poisonDeliveries <- newIORef (0 :: Int) - errors <- newIORef [] - let sub = SubscriptionName "orders-ack-poison" - opts = - (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) - { leaseTtl = 3, - renewInterval = 0.2, - handlerRetryDelay = KirokuSub.RetryDelay 0.05, - retryPolicy = KirokuSub.RetryPolicy 3, - onShardError = Just (\err -> modifyIORef' errors (err :)) - } - handler ev = do - let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) - if orderNumber == Right (1 :: Int) - then do - modifyIORef' poisonDeliveries (+ 1) - throwIO (userError "poison order") - else sinkHandler store 1 ev - worker <- forkIO (runShardedSubscriptionGroup store sub opts handler) - drained <- waitUntilSinkCount store (total - 1) 20_000_000 - details <- shardDeadLetterDetails store "orders-ack-poison" - attempts <- readIORef poisonDeliveries - seenErrors <- readIORef errors - killThread worker - drained `shouldBe` True - attempts `shouldBe` 3 - details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3) - seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) - - describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do - -- The headline operability signal: executed (real work) vs replayed - -- (recorded history), recorded by the runtime through an SDK meter and read - -- back from the in-memory exporter — plus the active gauge and the - -- journal-length histogram. - it "records workflow instruments through an SDK meter" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "obs" - wid = WorkflowId "obs-1" - opts = defaultWorkflowRunOptions & #metrics .~ Just metrics - -- First run: both steps miss → two executions. - first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) - first `shouldBe` Right (Completed (1, 2)) - -- Second run, same id: both steps hit → two replays. - second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) - second `shouldBe` Right (Completed (1, 2)) - -- The side effects ran exactly twice across both runs (the replay run - -- short-circuited every step). - readIORef counter >>= \c -> c `shouldBe` 2 - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - hists = flattenHistogramPoints exported - lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2) - lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2) - -- One journal-length observation per completed run (two completions). - [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2] - -- Both runs finished, so the live-run count returned to zero. - lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0) - - -- The resume worker increments keiro.workflow.resumed per re-invocation and - -- samples keiro.workflow.awakeables.pending each pass. - it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - meter <- getMeter provider Telemetry.keiroInstrumentationLibrary - metrics <- Telemetry.newKeiroMetrics meter - counter <- newIORef (0 :: Int) - let name = WorkflowName "obs-resume" - wid = WorkflowId "obs-r-1" - -- Park a workflow on the first of two gates, then journal that gate's - -- result. The append flips the instance row to running, which is what - -- makes exact discovery return it; the re-invocation then parks on the - -- second gate and stays Suspended, which still counts as a re-invocation. - suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (twoGateWorkflow counter) - suspended `shouldBe` Right Suspended - gateAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "awk:first" (toJSON ()) gateAt) - -- Register one pending awakeable (independent of the suspended workflow's - -- own await) so the pending gauge has something to count. - let aid = awakeableIdToUuid (generation0AwakeableId (WorkflowName "ext") (WorkflowId "1") "cb") - Right () <- - Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1" - -- One resume pass with metrics threaded through the run options. - let registry = Map.singleton name (WorkflowDef (\_wid -> twoGateWorkflow counter)) - resumeOpts = - defaultWorkflowResumeOptions - & #runOptions - .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry - (discovered summary, resumed summary, stillSuspended summary) `shouldBe` (1, 1, 1) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - let scalars = flattenScalarPoints exported - lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1) - lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1) - - -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics = - -- Nothing, so a run on a dedicated provider exports no points at all. - it "records nothing through a Nothing handle" $ \storeHandle -> do - (exporter, ref) <- inMemoryMetricExporter - (provider, _env) <- - createMeterProvider - emptyMaterializedResources - defaultSdkMeterProviderOptions {metricExporter = Just exporter} - counter <- newIORef (0 :: Int) - result <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter) - result `shouldBe` Right (Completed (1, 2)) - _ <- forceFlushMeterProvider provider Nothing - exported <- readIORef ref - flattenScalarPoints exported `shouldBe` [] - flattenHistogramPoints exported `shouldBe` [] - - describe "Keiro.Workflow.Snapshot codec" $ do - -- Pure (no-DB) round-trip of the workflow state codec. - it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do - let m = - Map.fromList - [ ("first", toJSON (1 :: Int)), - ("second", toJSON ["a", "b" :: Text]), - ("sleep:42", Aeson.Null) - ] - (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m - (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1" - (workflowStateCodec ^. #stateShapeHash) `shouldBe` "keiro.workflow.stepmap.v1" - (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1 - - describe "Keiro.Workflow.Types journal codec" $ do - -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the - -- additive WorkflowContinuedAsNew constructor encodes and decodes - -- self-describingly within schemaVersion 1. - it "round-trips a WorkflowContinuedAsNew rotation marker" $ do - let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600) - marker = WorkflowContinuedAsNew 3 t - (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker) - `shouldBe` Right marker - (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1 - EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True - - it "validates workflow identity smart constructors" $ do - mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment") - mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty - mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment") - mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment") - mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1") - mkWorkflowId "550e8400-e29b-41d4-a716-446655440000" - `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000") - mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty - mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42") - mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42") - - describe "Keiro deterministic id derivation" $ do - -- Deterministic ids are replay identity: the same seed must yield the same - -- id on every deploy, forever (ADR 24). Every literal below was captured - -- from the *previous* derivation — which hashed each character's codepoint - -- modulo 256 — before it was replaced by UTF-8 seed bytes. For ASCII seeds - -- the two encodings agree byte for byte, so a failure here means a - -- deployed id moved. Regenerate a literal only alongside a versioned - -- derivation and a migration story, never to make the suite green. - let name = WorkflowName "orderFulfillment" - wid = WorkflowId "wf-1" - sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301") - - it "freezes the ASCII journal-event ids, reserved step names included" $ do - deterministicJournalId name wid 0 "charge-card" - `shouldBe` EventId (uuidLiteral "1618b21a-5321-536f-998b-99f88f078148") - deterministicJournalId name wid 1 "charge-card" - `shouldBe` EventId (uuidLiteral "ddbf5d19-df0d-50f7-9aa2-9c8214bfde00") - deterministicJournalId name wid 0 completedStepName - `shouldBe` EventId (uuidLiteral "5ac985e8-4168-5705-91bc-5523833d3f60") - deterministicJournalId name wid 0 cancelledStepName - `shouldBe` EventId (uuidLiteral "52493d94-d35a-5a7e-8ce9-40e1111c45f9") - deterministicJournalId name wid 0 failedStepName - `shouldBe` EventId (uuidLiteral "b7ed900d-0fac-54dd-87b1-a01f6782a298") - deterministicJournalId name wid 0 continuedAsNewStepName - `shouldBe` EventId (uuidLiteral "338f8962-ef47-5992-a4e0-c314358a2f05") - deterministicJournalId name wid 0 continueSeedStepName - `shouldBe` EventId (uuidLiteral "268c2031-b026-564a-be24-85cab59c3ce7") - deterministicJournalId name wid 0 patchSetStepName - `shouldBe` EventId (uuidLiteral "c188a7f9-617d-59e5-8e09-4498d7daf477") - deterministicJournalId name wid 0 (patchStepName (PatchId "new-tax")) - `shouldBe` EventId (uuidLiteral "64de4580-0a2d-522b-b397-e25c6ee3eacc") - deterministicJournalId name wid 0 (sleepStepName (StepName "cool")) - `shouldBe` EventId (uuidLiteral "e3a009bd-f287-5331-9f72-8e273f0040cf") - - it "freezes the ASCII sleep, awakeable, and process-manager ids" $ do - sleepTimerId name wid 0 "sleep:cool" - `shouldBe` TimerId (uuidLiteral "cfebe58e-b34c-5031-af98-18e71e6f4cfa") - sleepTimerId name wid 1 "sleep:cool" - `shouldBe` TimerId (uuidLiteral "e9696450-3993-59da-902e-4e5ebcfd1ab0") - sleepTimerId name wid 2 "sleep:cool" - `shouldBe` TimerId (uuidLiteral "6affc998-5cf2-51d0-9bbb-22e792581433") - generation0AwakeableId name wid "approval" - `shouldBe` AwakeableId (uuidLiteral "f677231c-8a27-51b6-9a5e-69015262b26f") - deterministicCommandId "counter-pm" "order-1" sourceEventId 0 - `shouldBe` EventId (uuidLiteral "ff20892c-6665-5e92-8c99-d1569d2ce629") - deterministicCommandId "counter-pm" "order-1" sourceEventId (-1) - `shouldBe` EventId (uuidLiteral "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef") - - -- Each pair below produced one shared id under the old derivation, because - -- U+0101 and U+0001 (and U+4E2D/U+2E2D, U+6587/U+2587) agree modulo 256. - it "separates seeds the codepoint-truncating derivation collapsed" $ do - deterministicJournalId name wid 0 "\x0101" - `shouldNotBe` deterministicJournalId name wid 0 "\SOH" - deterministicJournalId name wid 0 "\x4E2D\x6587" - `shouldNotBe` deterministicJournalId name wid 0 "\x2E2D\x2587" - sleepTimerId name wid 0 "\x0101" - `shouldNotBe` sleepTimerId name wid 0 "\SOH" - generation0AwakeableId name wid "\x0101" - `shouldNotBe` generation0AwakeableId name wid "\SOH" - deterministicCommandId "counter-pm" "\x0101" sourceEventId 0 - `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 - - it "keeps the seed components positional" $ do - deterministicJournalId (WorkflowName "a") (WorkflowId "b") 0 "s" - `shouldNotBe` deterministicJournalId (WorkflowName "b") (WorkflowId "a") 0 "s" - deterministicCommandId "a" "b" sourceEventId 0 - `shouldNotBe` deterministicCommandId "b" "a" sourceEventId 0 - - around (withFreshStore fixture) $ - -- End to end: under the old derivation both step names hashed to one - -- event id, so the second append lost to the store's global event-id - -- uniqueness and this example returned @Left (DuplicateEvent Nothing)@ — - -- deterministically, on every retry, until the resume worker's - -- crash-backoff ladder marked the workflow failed. Now both steps - -- journal and the workflow completes. - it "runs a workflow whose step names collided under the old derivation" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let wfName = WorkflowName "unicodeSteps" - wfId = WorkflowId "us-1" - outcome <- - Store.runStoreIO storeHandle $ - runWorkflow wfName wfId (collidingStepWorkflow counter) - outcome `shouldBe` Right (Completed (1, 2)) - readIORef counter `shouldReturn` 2 - Right firstRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\x0101" - firstRecorded `shouldBe` True - Right secondRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\SOH" - secondRecorded `shouldBe` True - - describe "Keiro deterministic id legacy-encoding bridge" $ do - -- These values were captured by running the pre-UTF-8 implementation at - -- 7d7a200b in an isolated worktree. Do not regenerate them from the bridge - -- implementation: they are the independent evidence that it reproduces - -- deployed identity. - let sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301") - name = WorkflowName "legacy-awake" - wid = WorkflowId "la-1" - - it "reproduces every captured process-manager command id" $ do - let commandGoldens = - [ ("order-1", 0, "ff20892c-6665-5e92-8c99-d1569d2ce629"), - ("order-1", -1, "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef"), - ("Jos\x00E9", 0, "78cbd6e1-c15f-58c3-be0e-14c861de6c85"), - ("\x4E2D\x6587", 0, "58e6ef7b-a2c9-5e46-b580-db8df2ce72c7"), - ("\x4E2D\x6587", -1, "f276cf1b-0f5c-5427-a27a-f6d4ad2ca577"), - ("\x1F600", 0, "ddc163fc-3563-5ae6-a7f8-fbe1af2712b2"), - ("\x0101", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"), - ("\SOH", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"), - ("\x0169ser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115"), - ("iser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115") - ] - for_ commandGoldens $ \(correlation, emitIndex, golden) -> - legacyDeterministicCommandId "counter-pm" correlation sourceEventId emitIndex - `shouldBe` EventId (uuidLiteral golden) - legacyDeterministicCommandId "demo-router" "g-\x4E2D\x6587" sourceEventId 0 - `shouldBe` EventId (uuidLiteral "379ebaad-62e1-5265-9605-340789ae6af7") - - it "reproduces every captured deterministic awakeable id" $ do - preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" - `shouldBe` AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b") - preUtf8Generation0AwakeableId name wid "caf\x00E9" - `shouldBe` AwakeableId (uuidLiteral "446e5258-0697-525d-af06-0c2c3911ded7") - preUtf8Generation0AwakeableId name wid "\x4E2D" - `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de") - preUtf8Generation0AwakeableId name wid "-" - `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de") - - it "keeps ASCII identity stable and moves every non-ASCII capture" $ do - legacyDeterministicCommandId "counter-pm" "order-1" sourceEventId 0 - `shouldBe` deterministicCommandId "counter-pm" "order-1" sourceEventId 0 - legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0 - `shouldBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 - legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0 - `shouldBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0 - for_ ["Jos\x00E9", "\x4E2D\x6587", "\x1F600", "\x0101", "\x0169ser"] $ \correlation -> - legacyDeterministicCommandId "counter-pm" correlation sourceEventId 0 - `shouldNotBe` deterministicCommandId "counter-pm" correlation sourceEventId 0 - legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1) - `shouldNotBe` deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1) - preUtf8Generation0AwakeableId name wid "legacy" - `shouldBe` generation0AwakeableId name wid "legacy" - preUtf8Generation0AwakeableId name wid "-" - `shouldBe` generation0AwakeableId name wid "-" - for_ ["\x627F\x8A8D", "caf\x00E9", "\x4E2D"] $ \label -> - preUtf8Generation0AwakeableId name wid label - `shouldNotBe` generation0AwakeableId name wid label - - it "documents the historical truncation collisions and their UTF-8 separation" $ do - legacyDeterministicCommandId "counter-pm" "\x0101" sourceEventId 0 - `shouldBe` legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0 - deterministicCommandId "counter-pm" "\x0101" sourceEventId 0 - `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 - legacyDeterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0 - `shouldBe` legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0 - deterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0 - `shouldNotBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0 - preUtf8Generation0AwakeableId name wid "\x4E2D" - `shouldBe` preUtf8Generation0AwakeableId name wid "-" - generation0AwakeableId name wid "\x4E2D" - `shouldNotBe` generation0AwakeableId name wid "-" - - it "adds a legacy command probe only when the seed moved" $ do - NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "order-1" sourceEventId 0) - `shouldBe` [deterministicCommandId "counter-pm" "order-1" sourceEventId 0] - NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "\x4E2D\x6587" sourceEventId 0) - `shouldBe` [ deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0, - legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0 - ] - - it "builds one current probe for an ASCII seed" $ do - let seed = "keiro:probe:ascii" - NonEmpty.toList (deterministicIdProbes seed) - `shouldBe` [UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed)] - - it "orders the current and legacy probes for a non-ASCII seed" $ do - let seed = "keiro:probe:\x4E2D" - NonEmpty.toList (deterministicIdProbes seed) - `shouldBe` [ UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed), - UUID.V5.generateNamed UUID.V5.namespaceURL (legacySeedBytes seed) - ] - - describe "Keiro.Workflow.Sleep" $ do - -- Pure (no-DB) checks of the id/payload/step-name helpers. - it "derives a deterministic, distinct timer id" $ do - let name = WorkflowName "wf" - wid = WorkflowId "w-1" - sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a" - sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool" - (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other") - `shouldBe` False - sleepTimerId name wid 0 "sleep:cool" - `shouldBe` TimerId sleepGolden - sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool" - sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool" - - it "round-trips and recognises its timer payload" $ do - parseSleepPayload (sleepTimerPayload 2 "sleep:cool") - `shouldBe` Just ("sleep:cool", Just 2) - parseSleepPayload - ( object - [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text), - "step" Aeson..= ("sleep:legacy" :: Text) - ] - ) - `shouldBe` Just ("sleep:legacy", Nothing) - parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)]) - `shouldBe` Nothing - - it "recovers a legacy payload's generation from its deterministic timer id" $ do - let name = WorkflowName "wf" - wid = WorkflowId "w-legacy" - full = "sleep:cool" - for_ [0 .. 2] $ \gen -> - matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full) - `shouldBe` Just gen - - it "prefixes the journal step name with the reserved sleep prefix" $ - sleepStepName (StepName "cool") `shouldBe` "sleep:cool" - - around (withFreshStore fixture) $ do - it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepdemo" - wid = WorkflowId "sd-1" - journalStream = StreamName "wf:sleepdemo-sd-1" - TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" - -- First run: 'a' runs, the sleep arms a timer, and the run suspends. - outcome1 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) - outcome1 `shouldBe` Right Suspended - afterFirst <- readIORef counter - afterFirst `shouldBe` 1 - -- The journal holds only 'a' (no completion, no sleep:cool yet). - Right recorded1 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _] -> True - _ -> False - -- The durable wait is a single Scheduled timer row carrying the - -- workflow-sleep payload. - Right timerRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - timerRow `shouldSatisfy` \case - Just (status, payload) -> - status == "scheduled" - && parseSleepPayload payload == Just ("sleep:cool", Just 0) - Nothing -> False - -- Fire the timer through the routing worker (no PM fallback needed). - fireTime <- getCurrentTime - fireResult <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - case fireResult of - Right (Just timer) -> timer ^. #status `shouldBe` Firing - other -> expectationFailure ("expected a fired sleep timer, got " <> show other) - -- The row is now Fired and the journal gained sleep:cool. - Right afterFire <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst afterFire `shouldBe` Just "fired" - Right recorded2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True - _ -> False - -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs. - outcome2 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) - outcome2 `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - Right recorded3 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True - _ -> False - - it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepwait" - wid = WorkflowId "rt-1" - journalStream = StreamName "wf:sleepwait-rt-1" - clockBeforeFire <- getCurrentTime - outcome1 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - outcome1 `shouldBe` Right Suspended - afterFirst <- readIORef counter - afterFirst `shouldBe` 1 - -- A worker whose clock is before fire_at claims nothing. - notDue <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing clockBeforeFire workflowSleepFireAction - notDue `shouldBe` Right Nothing - Right recordedMid <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _] -> True - _ -> False - -- Wait out the one-second delay, then the worker fires it. - threadDelay 1_200_000 - afterDelay <- getCurrentTime - fired <- - Store.runStoreIO storeHandle $ - runTimerWorker Nothing afterDelay workflowSleepFireAction - fired `shouldSatisfy` \case - Right (Just _) -> True - _ -> False - Right recordedWoken <- - Store.runStoreIO storeHandle $ - Store.readStreamForward journalStream (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken) - `shouldSatisfy` \case - Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True - _ -> False - outcome2 <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - outcome2 `shouldBe` Right (Completed (1, 2)) - afterSecond <- readIORef counter - afterSecond `shouldBe` 2 - - it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleeponce" - wid = WorkflowId "so-1" - TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300) - Right (Just firstFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerFireAtStmt - Right summary <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered summary `shouldBe` 0 - Right (Just secondFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerFireAtStmt - secondFireAt `shouldBe` firstFireAt - readIORef counter >>= (`shouldBe` 1) - - it "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleep-wake-stable" - wid = WorkflowId "sws-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) - Right (Just firstWakeAfter) <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - - Right rearmed <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered rearmed `shouldBe` 1 - Right (Just secondWakeAfter) <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - secondWakeAfter `shouldBe` firstWakeAfter - - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right clearedWakeAfter <- - Store.runStoreIO storeHandle $ - workflowWakeAfter name wid - clearedWakeAfter `shouldBe` Nothing - - Right resumed <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered resumed `shouldBe` 1 - completed resumed `shouldBe` 1 - readIORef counter >>= (`shouldBe` 2) - - it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepwakeafter" - wid = WorkflowId "swa-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) - now <- getCurrentTime - Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - case mWakeAfter of - Nothing -> expectationFailure "expected wake_after" - Just wakeAfter -> wakeAfter `shouldSatisfy` (> now) - Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now - early `shouldBe` [] - Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now) - due `shouldBe` [("swa-1", "sleepwakeafter")] - - it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepquiet" - wid = WorkflowId "sq-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60)) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) - Right s1 <- pass - Right s2 <- pass - Right s3 <- pass - map discovered [s1, s2, s3] `shouldBe` [0, 0, 0] - readIORef counter >>= (`shouldBe` 1) - - it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do - let name = WorkflowName "sleepmissingrow" - wid = WorkflowId "smr-1" - body = sleepNamed (StepName "wait") 60 >> pure () - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldReturn` Right Suspended - - it "fires a sleep whose instance row is missing after an arm crash" $ \storeHandle -> do - let name = WorkflowName "sleep-missing-fire" - wid = WorkflowId "smf-1" - body = sleepNamed (StepName "wait") 0 - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right resolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 "sleep:wait" - resolved `shouldBe` True - Right (Just recovered) <- - Store.runStoreIO storeHandle $ - Instance.lookupInstance name wid - recovered ^. #status `shouldBe` Instance.WfRunning - Store.runStoreIO storeHandle (runWorkflow name wid body) - `shouldReturn` Right (Completed ()) - - it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleepactive" - wid = WorkflowId "sa-1" - registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) - threadDelay 1_200_000 - Right boundaryPass <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered boundaryPass `shouldBe` 1 - fireTime <- getCurrentTime - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) - Right completionPass <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - discovered completionPass `shouldBe` 1 - completed completionPass `shouldBe` 1 - readIORef counter >>= (`shouldBe` 2) - - it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleeproll" - wid = WorkflowId "sr-1" - registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter)) - drive 0 = expectationFailure "rolling sleep did not complete" - drive n = do - Right summary <- - Store.runStoreIO storeHandle $ - resumeWorkflowsOnce defaultWorkflowResumeOptions registry - now <- getCurrentTime - _ <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) - if completed summary == 1 - then pure () - else drive (n - 1) - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter) - drive (12 :: Int) - readIORef counter >>= (`shouldBe` 3) - - describe "Keiro.Timer batched drain" $ around (withFreshStore fixture) $ do - -- The single-claim worker drains a backlog at one timer per invocation, so - -- ten due sleeps take ten poll ticks and the last workflow wakes ticks late. - -- One drain pass wakes them all, with one requeue-and-gauge preamble instead - -- of ten. - it "drains a mixed backlog of sleeps and process-manager timers in one pass" $ \storeHandle -> do - firedPm <- newIORef ([] :: [Text]) - let sleepers = [1 .. 4 :: Int] - sleeperName = WorkflowName "drain-sleeper" - sleeperId i = WorkflowId ("ds-" <> Text.pack (show i)) - for_ sleepers $ \i -> do - outcome <- - Store.runStoreIO storeHandle $ - runWorkflow sleeperName (sleeperId i) (sleepNamed (StepName "wait") 0) - outcome `shouldBe` Right Suspended - for_ [1 .. 6 :: Int] $ \i -> - Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i))) - `shouldReturn` Right () - now <- addUTCTime 1 <$> getCurrentTime - Right drained <- - Store.runStoreIO storeHandle $ - drainWorkflowSleepTimers Nothing now 20 $ \row -> do - liftIO (modifyIORef' firedPm (row ^. #correlationId :)) - pure (Just (EventId sampleUuid2)) - drained `shouldBe` 10 - -- Every sleep actually woke: the completion is journaled, not merely - -- claimed. - for_ sleepers $ \i -> do - Right woke <- Store.runStoreIO storeHandle $ stepExists sleeperName (sleeperId i) 0 "sleep:wait" - woke `shouldBe` True - readIORef firedPm >>= \fired -> length fired `shouldBe` 6 - -- Nothing is left claimable. - Right leftovers <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 (\_ -> pure Nothing) - leftovers `shouldBe` 0 - - it "stops at the batch limit and leaves the rest claimable" $ \storeHandle -> do - for_ [1 .. 10 :: Int] $ \i -> - Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i))) - `shouldReturn` Right () - now <- addUTCTime 1 <$> getCurrentTime - let fireOne _ = pure (Just (EventId sampleUuid2)) - Right firstBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 3 fireOne - firstBatch `shouldBe` 3 - Right restBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne - restBatch `shouldBe` 7 - -- A limit of zero still runs the preamble but claims nothing, and an - -- empty backlog costs exactly what a single-claim pass costs. - Right noneLeft <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne - noneLeft `shouldBe` 0 - - describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do - it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleep-generation-pin" - wid = WorkflowId "sgp-1" - full = "sleep:cool" - TimerId generationZeroTimerId = sleepTimerId name wid 0 full - TimerId generationOneTimerId = sleepTimerId name wid 1 full - body = do - seed <- restoreSeed (0 :: Int) - _ <- step (StepName "work") (liftIO (incrementAndRead counter)) - if seed == 0 - then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int) - else sleepNamed (StepName "cool") 3600 >> pure seed - - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - claimTime <- getCurrentTime - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime - claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId - Right (Just _) <- - Store.runStoreIO storeHandle $ - workflowSleepFireAction claimed - - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right (Just generationOneFireAt) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerFireAtStmt - - requeueTime <- getCurrentTime - Right requeued <- - Store.runStoreIO storeHandle $ - requeueStuckTimers 0 (addUTCTime 1 requeueTime) - requeued `shouldBe` 1 - Right (Just staleFire) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing) - staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId - - Right generationOneResolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 1 full - generationOneResolved `shouldBe` False - Right (Just instanceRow) <- - Store.runStoreIO storeHandle $ - Instance.lookupInstance name wid - instanceRow ^. #status `shouldBe` Instance.WfSuspended - Right generationZeroStatus <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationZeroTimerId sleepTimerStatusStmt - fmap fst generationZeroStatus `shouldBe` Just "fired" - Right generationOneStatus <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerStatusStmt - fmap fst generationOneStatus `shouldBe` Just "scheduled" - Right (Just generationOneFireAtAfter) <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement generationOneTimerId sleepTimerFireAtStmt - generationOneFireAtAfter `shouldBe` generationOneFireAt - readIORef counter >>= (`shouldBe` 2) - - describe "Keiro.Workflow wake-lifecycle visibility" $ around (withFreshStore fixture) $ do - -- Cancelling an awakeable writes no journal entry, so it is the one - -- wake-source lifecycle transition that would otherwise leave the owning - -- instance row untouched. It must still leave the workflow discoverable, or - -- the workflow can never reach its await arm to observe the cancellation. - it "flips the owner instance to running when its awakeable is cancelled" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "cancel-visible" - wid = WorkflowId "cv-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - parked ^. #status `shouldBe` Instance.WfSuspended - Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid - cancelled `shouldBe` True - Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - woken ^. #status `shouldBe` Instance.WfRunning - woken ^. #generation `shouldBe` 0 - now <- getCurrentTime - Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - unfinished `shouldBe` [("cv-1", "cancel-visible")] - -- The pass re-invokes the workflow; its await arm sees the cancelled row - -- and throws, which the worker records as a crash attempt. - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) - Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - crashed ^. #attempts `shouldBe` 1 - fmap Text.unpack (crashed ^. #lastError) - `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") - - -- Only the first arm writes wake_after, so a stale re-fire that clears it - -- erases a hint nothing will rewrite. Only a fresh append is a successful - -- fire in ADR 7's sense. - it "leaves a newer sleep's wake hint intact when a stale timer re-fires" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "sleep-refire" - wid = WorkflowId "sr-2" - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter) - claimTime <- getCurrentTime - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime - claimed ^. #timerId `shouldBe` sleepTimerId name wid 0 (sleepStepName (StepName "first")) - -- Fire the first sleep, then "crash" before the worker marks the timer - -- fired: the row stays in `firing` and is requeued below. - Right firstFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed - firstFire `shouldSatisfy` isJust - Right cleared <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - cleared `shouldBe` Nothing - -- The next run replays past the first sleep and arms the second one, - -- whose insert writes the live wake hint. - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter) - Right (Just liveHint) <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - liveHint `shouldSatisfy` (> claimTime) - requeueTime <- getCurrentTime - Right requeued <- - Store.runStoreIO storeHandle $ requeueStuckTimers 0 (addUTCTime 1 requeueTime) - requeued `shouldBe` 1 - Right (Just stale) <- - Store.runStoreIO storeHandle $ claimDueTimer (addUTCTime 2 requeueTime) - (stale ^. #timerId) `shouldBe` (claimed ^. #timerId) - Right staleFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction stale - -- Still idempotent: the re-fire reports the same deterministic event id. - staleFire `shouldBe` firstFire - Right hintAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - hintAfter `shouldBe` Just liveHint - readIORef counter >>= (`shouldBe` 1) - - describe "Keiro.Workflow exact discovery" $ around (withFreshStore fixture) $ do - it "hides a workflow parked on an awakeable until it is signalled" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "quiet-awk" - wid = WorkflowId "qa-1" - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - parkedAt <- getCurrentTime - Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) - parked `shouldBe` [] - -- The whole point: a parked workflow costs a pass nothing at all. - Right idle <- pass - idle `shouldBe` emptyResumeSummary - Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - wokenAt <- getCurrentTime - Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - woken `shouldBe` [("qa-1", "quiet-awk")] - Right finish <- pass - (discovered finish, completed finish) `shouldBe` (1, 1) - doneAt <- getCurrentTime - Right afterCompletion <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds doneAt) - afterCompletion `shouldBe` [] - - -- The parent is invisible while it waits, but the freshly spawned child is - -- discovered from the instance row spawnChild writes in the spawn step's - -- transaction — which is why the resume worker no longer needs a separate - -- findRunningChildIds seed. - it "hides a parent parked on a child while still discovering the zero-step child" $ \storeHandle -> do - let parentName = WorkflowName "quiet-parent" - parentWid = WorkflowId "qp-1" - childName = WorkflowName "ship" - childWid = WorkflowId "ship-quiet" - registry = Map.singleton parentName (WorkflowDef (\_ -> parentWorkflow childWid)) - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentWid (parentWorkflow childWid) - parkedAt <- getCurrentTime - Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) - parked `shouldBe` [("ship-quiet", "ship")] - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions childName childWid shipWorkflow - wokenAt <- getCurrentTime - Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - woken `shouldBe` [("qp-1", "quiet-parent")] - Right finish <- - Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - (discovered finish, completed finish) `shouldBe` (1, 1) - - -- Wake-wins ordering. markInstanceSuspendedAwaiting is exactly the write a - -- run performs after its (now stale) index miss, so calling it directly - -- after a signal reproduces the race deterministically. - it "writes running when the wake landed before the suspend write" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "race-wake-first" - wid = WorkflowId "rwf-1" - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - Right () <- - Store.runStoreIO storeHandle $ - Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - arbitrated ^. #status `shouldBe` Instance.WfRunning - wokenAt <- getCurrentTime - Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - woken `shouldBe` [("rwf-1", "race-wake-first")] - Right finish <- - Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - completed finish `shouldBe` 1 - - -- Suspend-wins ordering: the wake, queued behind the suspend write on the - -- same per-step lock, flips the instance itself. - it "flips a suspended instance to running when the wake lands after the suspend write" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "race-suspend-first" - wid = WorkflowId "rsf-1" - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right () <- - Store.runStoreIO storeHandle $ - Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - Right (Just parkedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - parkedRow ^. #status `shouldBe` Instance.WfSuspended - parkedAt <- getCurrentTime - Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) - invisible `shouldBe` [] - Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - Right (Just wokenRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - wokenRow ^. #status `shouldBe` Instance.WfRunning - Right finish <- - Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - completed finish `shouldBe` 1 - - it "stays discoverable when a cancel lands before the stale suspend write" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "race-cancel-first" - wid = WorkflowId "rcf-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid - Right () <- - Store.runStoreIO storeHandle $ - Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - arbitrated ^. #status `shouldBe` Instance.WfRunning - wokenAt <- getCurrentTime - Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - woken `shouldBe` [("rcf-1", "race-cancel-first")] - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) - Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - crashed ^. #attempts `shouldBe` 1 - fmap Text.unpack (crashed ^. #lastError) - `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") - - it "flips a suspended instance to running when the cancel lands after the suspend write" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "race-cancel-second" - wid = WorkflowId "rcs-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right () <- - Store.runStoreIO storeHandle $ - Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - parked ^. #status `shouldBe` Instance.WfSuspended - parkedAt <- getCurrentTime - Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) - invisible `shouldBe` [] - Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid - Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - woken ^. #status `shouldBe` Instance.WfRunning - wokenAt <- getCurrentTime - Right discoveredNow <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) - discoveredNow `shouldBe` [("rcs-1", "race-cancel-second")] - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) - Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - crashed ^. #attempts `shouldBe` 1 - fmap Text.unpack (crashed ^. #lastError) - `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") - - it "surfaces a due sleep through the wake hint and a fired sleep through running" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "quiet-sleep" - wid = WorkflowId "qs-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) - now <- getCurrentTime - Right early <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) - early `shouldBe` [] - -- Due, but the timer worker has not fired it yet: the suspended arm. - let dueAt = addUTCTime 61 now - Right due <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds dueAt) - due `shouldBe` [("qs-1", "quiet-sleep")] - Right (Just _) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing dueAt (\_ -> pure Nothing) - Right (Just fired) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - fired ^. #status `shouldBe` Instance.WfRunning - Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - hint `shouldBe` Nothing - -- Now discovered through the running arm, with no hint left to expire. - firedAt <- getCurrentTime - Right visible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds firedAt) - visible `shouldBe` [("qs-1", "quiet-sleep")] - - -- A crashed workflow stays 'running', so exact discovery keeps returning it; - -- what paces the retry is claimInstance's next_attempt_at gate, which is - -- reported distinctly from a live foreign lease. - it "keeps a crashed workflow discovered while its backoff gate paces retries" $ \storeHandle -> do - let name = WorkflowName "crash-visible" - wid = WorkflowId "cvz-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 3 - & #logEvent - .~ const (pure ()) - registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) - seededAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) - Right first <- pass - (discovered first, resumed first, failed first) `shouldBe` (1, 1, 0) - Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - crashed ^. #status `shouldBe` Instance.WfRunning - crashed ^. #attempts `shouldBe` 1 - Right second <- pass - (discovered second, paced second, leaseSkipped second) `shouldBe` (1, 1, 0) - - it "a bounded drain loop terminates over a pool that cannot advance" $ \storeHandle -> do - let crashName = WorkflowName "drain-crash" - crashWid = WorkflowId "drain-crash-1" - ghostName = WorkflowName "drain-ghost" - ghostWid = WorkflowId "drain-ghost-1" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 3 - & #logEvent - .~ const (pure ()) - registry = - Map.singleton - crashName - (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) - drain 0 acc = pure acc - drain n acc = do - Right summary <- pass - if advanced summary > 0 - then drain (n - 1 :: Int) (acc <> [summary]) - else pure (acc <> [summary]) - seededAt <- getCurrentTime - for_ [(crashName, crashWid), (ghostName, ghostWid)] $ \(name, wid) -> do - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) - pure () - passes <- drain 10 [] - length passes `shouldBe` 1 - case passes of - [summary] -> do - (discovered summary, resumed summary, unknownName summary, advanced summary) - `shouldBe` (2, 1, 1, 0) - unregisteredNames summary `shouldBe` Set.singleton "drain-ghost" - other -> expectationFailure ("expected one drain pass, got " <> show other) - Right blocked <- pass - (discovered blocked, paced blocked, unknownName blocked, advanced blocked) - `shouldBe` (2, 1, 1, 0) - unregisteredNames blocked `shouldBe` Set.singleton "drain-ghost" - - it "a bounded drain loop terminates over a due sleep with no timer worker" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "drain-due-sleep" - wid = WorkflowId "dds-1" - opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) - registry = - Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") (-1))) - pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) - drain 0 acc = pure acc - drain n acc = do - Right summary <- pass - if advanced summary > 0 - then drain (n - 1 :: Int) (acc <> [summary]) - else pure (acc <> [summary]) - -- Arm the sleep with an already-due fire time. No timer worker ever fires it. - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") (-1)) - readIORef counter `shouldReturn` 1 - passes <- drain 5 [] - length passes `shouldBe` 1 - case passes of - [summary] -> - (discovered summary, resumed summary, stillSuspended summary, advanced summary, sleepDue summary) - `shouldBe` (1, 1, 1, 0, 1) - other -> expectationFailure ("expected one drain pass, got " <> show other) - Right blocked <- pass - (discovered blocked, stillSuspended blocked, advanced blocked, sleepDue blocked) - `shouldBe` (1, 1, 0, 1) - -- Replay-only: neither step body re-ran. - readIORef counter `shouldReturn` 1 - -- The candidate is still discoverable, blocked on the timer worker rather than lost. - Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - row ^. #status `shouldBe` Instance.WfSuspended - Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid - hint `shouldSatisfy` isJust - - describe "Keiro.Workflow terminal boundaries" $ around (withFreshStore fixture) $ do - -- The asymmetry this closes: cancellation stopped a run at the next step - -- boundary, terminal failure did not. Before the append transaction checked - -- both markers, this workflow ran step "two" and reported Completed. - it "stops at the next step boundary when a workflow is failed mid-run" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "self-fail" - wid = WorkflowId "sf-1" - outcome <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (selfFailingWorkflow name wid counter) - outcome `shouldBe` Right Keiro.Workflow.Failed - -- Step one's action ran (its side effect is at-least-once at boundaries); - -- step two's never did. - readIORef counter `shouldReturn` 1 - -- Step one's own append is the one the in-transaction check has to refuse: - -- the marker landed *inside* that action, after the pre-action probe had - -- already passed. Nothing more is journaled into a terminal workflow. - Right recordedOne <- Store.runStoreIO storeHandle $ stepExists name wid 0 "one" - recordedOne `shouldBe` False - Right recordedTwo <- Store.runStoreIO storeHandle $ stepExists name wid 0 "two" - recordedTwo `shouldBe` False - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:self-fail-sf-1") (StreamVersion 0) 10 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - any (\case WorkflowFailed {} -> True; _ -> False) decoded `shouldBe` True - any (\case StepRecorded "two" _ _ -> True; _ -> False) decoded `shouldBe` False - - it "declines an ordinary append into a cancelled workflow without erroring" $ \storeHandle -> do - let name = WorkflowName "refuse-cancelled" - wid = WorkflowId "rc-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled now) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) - Right present <- Store.runStoreIO storeHandle $ stepExists name wid 0 "late" - present `shouldBe` False - - -- A wake source settles its own durable row even when it cannot deliver: - -- the promise is resolved, the journal entry is not written. - it "completes an awakeable owned by a failed workflow but journals nothing" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "refuse-signal" - wid = WorkflowId "rs-1" - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - failedAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt) - Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Completed - Right delivered <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - delivered `shouldBe` False - - -- The refusal reads the derived failure-marker index row, which - -- resurrection deletes, so a revived workflow accepts deliveries again by - -- construction (ADR 8: failure history is immutable, derived state is - -- revivable). - it "accepts a wake append again after the workflow is resurrected" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "revive-delivery" - wid = WorkflowId "rd-1" - Right Suspended <- - Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - failedAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt) - Right Instance.WorkflowResurrected <- - Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid - Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right delivered <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid) - delivered `shouldBe` True - Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) - `shouldReturn` Right (Completed "ok!") - - -- Defense in depth for the sleep fire: its instance-status guard cannot see - -- a cancellation whose instance row was already collected, but the append - -- transaction still refuses. The timer is marked fired regardless, so it is - -- not requeued forever against a workflow that will never accept it. - it "marks a sleep timer fired without delivering into a cancelled workflow" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "refuse-sleep" - wid = WorkflowId "rsl-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled cancelledAt) - -- Partial GC: the instance row is gone, so the fire action's terminal - -- guard finds nothing and proceeds to the append. - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("rsl-1", "refuse-sleep") deleteWorkflowInstanceStmt - claimTime <- getCurrentTime - Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime - Right fired <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed - fired `shouldSatisfy` isJust - Right delivered <- Store.runStoreIO storeHandle $ stepExists name wid 0 "sleep:wait" - delivered `shouldBe` False - - describe "Keiro.Workflow.Awakeable" $ do - -- Pure (no-DB) check of the frozen generation-0 compatibility derivation. - it "reproduces a stable, label-sensitive generation-0 AwakeableId" $ do - let aid1 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval" - aid2 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval" - aidOther = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "other" - awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279" - aid1 `shouldBe` aid2 - (aid1 == aidOther) `shouldBe` False - aid1 `shouldBe` AwakeableId awakeableGolden - - around (withFreshStore fixture) $ do - it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do - let aidA = awakeableIdToUuid (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "a") - aidB = awakeableIdToUuid (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "b") - now <- getCurrentTime - Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do - Awk.registerAwakeableTx aidA "sch" "1" - Awk.registerAwakeableTx aidB "sch" "1" - Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingCount `shouldBe` 2 - Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA - rowA ^. #status `shouldBe` Awk.Pending - rowA ^. #payload `shouldBe` Nothing - -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op. - Right firstComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now - firstComplete `shouldBe` True - Right secondComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now - secondComplete `shouldBe` False - Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA - rowA' ^. #status `shouldBe` Awk.Completed - rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text)) - -- Cancel the still-pending B; both rows are now resolved. The guarded - -- UPDATE returns the owner coordinates so the caller can flip the - -- owning instance row in the same transaction. - Right cancelled <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.cancelAwakeableTx aidB - cancelled `shouldBe` Just ("sch", "1") - Right reCancelled <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.cancelAwakeableTx aidB - reCancelled `shouldBe` Nothing - Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingAfter `shouldBe` 0 - - it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "approval" - wid = WorkflowId "wf1" - outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - outcome1 `shouldBe` Right Suspended - aid <- readRequiredAwakeableId aidRef - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Pending - row ^. #payload `shouldBe` Nothing - Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables - pendingNow `shouldBe` 1 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) - `shouldSatisfy` \case - Right [StepRecorded stepName value _] -> - stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid - _ -> False - - it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "approval" - wid = WorkflowId "wf1" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Completed - row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) - Right afterSignal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal) - `shouldSatisfy` \case - Right [StepRecorded allocStep _ _, StepRecorded s r _] -> - allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text) - _ -> False - outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - outcome2 `shouldBe` Right (Completed "ok!") - Right afterResume <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume) - `shouldSatisfy` \case - Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> - allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep - _ -> False - - it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "idem" - wid = WorkflowId "wf-i" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text) - again `shouldBe` False - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - - it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "cancelwf" - wid = WorkflowId "wf2" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid - cancelled `shouldBe` True - Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) - row ^. #status `shouldBe` Awk.Cancelled - Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) - `shouldThrow` (== WorkflowAwakeableCancelled aid) - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - any (\case WorkflowCompleted {} -> True; _ -> False) decoded `shouldBe` False - - it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "crash" - wid = WorkflowId "wf3" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - -- Simulate "row completed but the journal append did not happen" by - -- completing the row directly, bypassing signalAwakeable's journal write. - now <- getCurrentTime - Right completedRow <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now - completedRow `shouldBe` True - Right beforeRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 - Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) - [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` [] - -- A re-signal with the same payload returns False (already completed) but - -- repairs the missing journal entry from the stored payload. - Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) - repaired `shouldBe` False - Right afterRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 - Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) - [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - - it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "crash-arm" - wid = WorkflowId "wf4" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - let awkStep = "awk:" <> awakeableIdText aid - now <- getCurrentTime - Right True <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now - repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - repairedRun `shouldBe` Right Suspended - Right repairedJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100 - Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal)) - [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "fresh-awake" - wid = WorkflowId "fa-1" - forged = generation0AwakeableId name wid "approval" - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - real <- readRequiredAwakeableId aidRef - real `shouldNotBe` forged - Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text) - forgedSignal `shouldBe` False - Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - stillSuspended `shouldBe` Suspended - Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text) - realSignal `shouldBe` True - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "legacy-awake" - wid = WorkflowId "la-1" - legacy = generation0AwakeableId name wid "approval" - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - adopted <- readRequiredAwakeableId aidRef - adopted `shouldBe` legacy - Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "adopts a pre-UTF-8 generation-0 row for a non-ASCII label" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "legacy-awake" - wid = WorkflowId "la-1" - legacy = AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b") - preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" `shouldBe` legacy - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef) - adopted <- readRequiredAwakeableId aidRef - adopted `shouldBe` legacy - Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef) - completed `shouldBe` Right (Completed "ok!") - - it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do - idsRef <- newIORef [] - let name = WorkflowName "awake-roll" - wid = WorkflowId "ar-1" - body = rollingAwakeableWorkflow idsRef - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - ids1 <- readIORef idsRef - [firstAid] <- pure ids1 - Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text) - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - ids2 <- readIORef idsRef - case ids2 of - [firstAgain, secondAid] -> do - firstAgain `shouldBe` firstAid - secondAid `shouldNotBe` firstAid - Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text) - staleSignal `shouldBe` False - Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body - stillSuspended `shouldBe` Suspended - Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text) - completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body - completed `shouldBe` Right (Completed "second") - other -> expectationFailure ("expected two awakeable ids, got " <> show other) - - describe "Keiro.Workflow awakeable registration" $ around (withFreshStore fixture) $ do - it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "awakeable-signal-gap" - wid = WorkflowId "asg-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (publishAwakeableBeforeAwait aidRef) - aid <- readRequiredAwakeableId aidRef - Right (Just pendingRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - pendingRow ^. #status `shouldBe` Awk.Pending - - Right signalled <- - Store.runStoreIO storeHandle $ - signalAwakeable aid ("ok" :: Text) - signalled `shouldBe` True - Right (Just completedRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - completedRow ^. #status `shouldBe` Awk.Completed - - let unknown = - AwakeableId - (uuidLiteral "00000000-0000-0000-0000-0000000002f2") - Right unknownSignal <- - Store.runStoreIO storeHandle $ - signalAwakeable unknown ("forged" :: Text) - unknownSignal `shouldBe` False - - completed <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (awaitPublishedAwakeable aidRef) - completed `shouldBe` Right (Completed "ok") - - describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do - it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do - aidRef <- newIORef Nothing - let name = WorkflowName "awakeable-cancel-race" - wid = WorkflowId "acr-1" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (approvalFlowWithId aidRef) - aid <- readRequiredAwakeableId aidRef - Right (Just stalePendingRow) <- - Store.runStoreIO storeHandle $ - Awk.lookupAwakeable (awakeableIdToUuid aid) - Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid - cancelled `shouldBe` True - Right signalled <- - Store.runStoreIO storeHandle $ - signalAwakeableFrom stalePendingRow ("late" :: Text) - signalled `shouldBe` False - Right recorded <- - Store.runStoreIO storeHandle $ - stepExists - name - wid - 0 - (awakeableStepPrefix <> awakeableIdText aid) - recorded `shouldBe` False - Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) - `shouldThrow` (== WorkflowAwakeableCancelled aid) - - describe "Keiro.Workflow.Child" $ do - -- M2: the reserved spawn/result step-name derivations are stable. - it "derives the child spawn and result step names" $ do - childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1" - childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result" - - -- M3(a): the new terminal journal constructors round-trip through the codec. - it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do - let t = UTCTime (ModifiedJulianDay 0) 0 - rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev) - rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t) - rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t) - - around (withFreshStore fixture) $ do - -- M1: the keiro_workflow_children table and its schema helpers. - it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result" - Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship" - row ^. #status `shouldBe` Child.Running - row ^. #parentId `shouldBe` "p-1" - row ^. #parentName `shouldBe` "parent" - row ^. #awaitStep `shouldBe` "child:c-1:result" - now <- getCurrentTime - Right firstComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now - firstComplete `shouldBe` True - Right secondComplete <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now - secondComplete `shouldBe` False - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result" - Right cancelled <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "c-2" "ship" - cancelled `shouldBe` True - Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent" - map (^. #childId) kids `shouldBe` ["c-1", "c-2"] - Right active <- Store.runStoreIO storeHandle Child.countActiveChildren - active `shouldBe` (0 :: Int) - Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship" - st `shouldBe` Just Child.ChildCompleted - - -- M4: spawn -> drive the child (with the completion hook) -> resume parent. - it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do - let childWid = WorkflowId "ship-1" - suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) - suspended `shouldBe` Right Suspended - Right parentJournal1 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1)) - decoded1 `shouldSatisfy` \case - [StepRecorded "child:ship-1" _ _] -> True - _ -> False - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" - childRow ^. #status `shouldBe` Child.Running - childRow ^. #parentId `shouldBe` "p1" - childRow ^. #parentName `shouldBe` "parent" - childRow ^. #awaitStep `shouldBe` "child:ship-1:result" - -- 2) drive the child through runChildWorkflow (propagates on completion). - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right (Completed "packed+labelled") - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10 - traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal) - `shouldSatisfy` \case - Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True - _ -> False - Right parentJournal2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2)) - [r | StepRecorded "child:ship-1:result" r _ <- decoded2] - `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] - Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" - childRow2 ^. #status `shouldBe` Child.ChildCompleted - -- 3) resume the parent: it replays past awaitChild and completes. - resumed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) - resumed `shouldBe` Right (Completed "done:packed+labelled") - Right parentJournal3 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 - Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3)) - any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True - any (\case WorkflowCompleted {} -> True; _ -> False) decoded3 `shouldBe` True - - it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do - let childWid = WorkflowId "ship-crash" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - now <- getCurrentTime - Right transitioned <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now - transitioned `shouldBe` True - Right beforeRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 - Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) - [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` [] - repaired <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - repaired `shouldBe` Right Suspended - Right afterRepair <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 - Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) - [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded] - `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] - completed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) - completed `shouldBe` Right (Completed "done:packed+labelled") - - -- M5: re-invoking the parent does not re-spawn the child (crash survival). - it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do - let childWid = WorkflowId "ship-2" - s1 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) - s1 `shouldBe` Right Suspended - Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship" - let createdAt0 = beforeRow ^. #createdAt - s2 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) - s2 `shouldBe` Right Suspended - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1 - Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent" - length kids `shouldBe` 1 - map (^. #createdAt) kids `shouldBe` [createdAt0] - - -- M5: cancelling a child stops it and makes the parent's awaitChild throw. - it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child" - h = ChildHandle (WorkflowName "ship") childWid - s1 <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid) - s1 `shouldBe` Right Suspended - Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h - cancelled `shouldBe` True - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True - Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship" - st `shouldBe` Just Child.ChildCancelled - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - -- driving the child returns Cancelled and runs none of its steps. - childOutcome <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right Keiro.Workflow.Cancelled - Right childJournal2 <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 - Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2)) - any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False - -- re-invoking the parent throws WorkflowChildCancelled. - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)) - `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid) - - it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child-crash" - h = ChildHandle (WorkflowName "ship") childWid - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid) - Right transitioned <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "cancel-child-crash" "ship" - transitioned `shouldBe` True - Right retried <- Store.runStoreIO storeHandle $ cancelChild h - retried `shouldBe` False - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - - it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do - let childWid = WorkflowId "cancel-child-drive" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid) - Right True <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Child.markChildCancelledTx "cancel-child-drive" "ship" - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right Keiro.Workflow.Cancelled - Right childJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10 - Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) - any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded] - `shouldBe` [object ["cancelled" Aeson..= True]] - - it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do - let childWid = WorkflowId "json-cancelled-object" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow - childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) - completed <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) - completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded] - `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]] - - it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do - let childWid = WorkflowId "decode-child" - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid) - Store.runStoreIO - storeHandle - (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int))) - `shouldReturn` Right () - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)) - `shouldThrow` \case - WorkflowStepDecodeError key _ -> key == "child:decode-child:result" - _ -> False - - it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do - let childWid = WorkflowId "failed-child" - registry = - Map.fromList - [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), - (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) - ] - opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship" - childRow ^. #status `shouldBe` Child.ChildFailed - Store.runStoreIO - storeHandle - (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)) - `shouldThrow` \case - WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason -> - "SimulatedCrash" `Text.isInfixOf` reason - _ -> False - - it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do - counter <- newIORef 0 - let name = WorkflowName "self-cancel" - wid = WorkflowId "sc1" - outcome <- - Store.runStoreIO storeHandle $ - runWorkflow name wid (selfCancellingWorkflow name wid counter) - outcome `shouldBe` Right Keiro.Workflow.Cancelled - readIORef counter `shouldReturn` 2 - Right recorded <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10 - Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) - any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False - - -- EP-42 worker-driven variant: the resume worker drives both parent and - -- child from a registry, selecting childCompletionHook for the child and - -- union-discovering the zero-step child. - it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do - let childWid = WorkflowId "ship-3" - registry = - Map.fromList - [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), - (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow)) - ] - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid) - let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) - Right _ <- drive - Right _ <- drive - Right _ <- drive - Right parentJournal <- - Store.runStoreIO storeHandle $ - Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10 - Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) - any (\case WorkflowCompleted {} -> True; _ -> False) parentDecoded `shouldBe` True - Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship" - childRow ^. #status `shouldBe` Child.ChildCompleted - - it "attaches to a completed child after continueAsNew" $ \storeHandle -> do - let childWid = WorkflowId "ship-rotated" - parentName = WorkflowName "parent-rotating" - parentId = WorkflowId "p-rotating" - body = rotatingParentWorkflow childWid - Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - childOutcome <- - Store.runStoreIO storeHandle $ - runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow - childOutcome `shouldBe` Right (Completed "packed+labelled") - Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - repair `shouldBe` Right Suspended - completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body - completed `shouldBe` Right (Completed "packed+labelled") - - describe "Keiro.Workflow.Child durable failed delivery" $ around (withFreshStore fixture) $ do - it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do - let childWid = WorkflowId "failed-before-rotation" - parentName = WorkflowName "parent-failure-rotation" - parentId = WorkflowId "p-failure-rotation" - registry = - Map.fromList - [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)), - (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) - ] - opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (failedChildBeforeRotation childWid) - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - failed summary `shouldBe` 1 - Right (Just childRow) <- - Store.runStoreIO storeHandle $ - Child.lookupChild "failed-before-rotation" "ship" - childRow ^. #status `shouldBe` Child.ChildFailed - childRow ^. #failureReason - `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`) - Right failedOnGenerationZero <- - Store.runStoreIO storeHandle $ - stepExists - parentName - parentId - 0 - (childResultStepName childWid) - failedOnGenerationZero `shouldBe` True - - Right ContinuedAsNew <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (rotatePastFailedChild childWid) - Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId - generation `shouldBe` 1 - Right failedOnGenerationOne <- - Store.runStoreIO storeHandle $ - stepExists - parentName - parentId - 1 - (childResultStepName childWid) - failedOnGenerationOne `shouldBe` False - - delivered <- - Store.runStoreIO storeHandle $ - runWorkflow parentName parentId (catchFailedChildAfterRotation childWid) - delivered `shouldSatisfy` \case - Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason - _ -> False - - describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do - it "deletes terminal workflow data after retention" $ \storeHandle -> do - let name = WorkflowName "gc-basic" - wid = WorkflowId "gb-1" - gcStreamName = workflowGenerationStreamName name wid 0 - aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1") - timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2") - counter <- newIORef (0 :: Int) - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflowWith - (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) - name - wid - (demoWorkflow counter) - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Awk.registerAwakeableTx aid "gc-basic" "gb-1" - Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt - Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" - beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1) - Right freshSummary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - now - WorkflowGc.WorkflowGcPolicy {retention = 3600, batchSize = 10} - freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} - Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName - Right deletedSummary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName - Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" - afterCounts `shouldBe` (0, 0, 0, 0, 0, 0) - - it "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let name = WorkflowName "gc-scheduled-sleep" - wid = WorkflowId "gss-1" - journalStream = workflowGenerationStreamName name wid 0 - TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait" - body = do - _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter)) - sleepNamed (StepName "wait") 3600 - Right Suspended <- - Store.runStoreIO storeHandle $ - runWorkflow name wid body - Right timerBeforeGc <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst timerBeforeGc `shouldBe` Just "scheduled" - - cancelledAt <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry name wid (WorkflowCancelled cancelledAt) - gcClock <- getCurrentTime - Right collected <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 gcClock) - WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} - - Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - Right timerAfterGc <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - timerAfterGc `shouldBe` Nothing - - Right noClaim <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing) - noClaim `shouldBe` Nothing - Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - readIORef counter >>= (`shouldBe` 1) - - it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do - let name = WorkflowName "gc-terminal-fire" - wid = WorkflowId "gtf-1" - full = "sleep:wait" - timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full - journalStream = workflowGenerationStreamName name wid 0 - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing - void $ - scheduleTimerOnceTx - TimerRequest - { timerId, - processManagerName = "gc-terminal-fire", - correlationId = "gtf-1", - fireAt = now, - payload = sleepTimerPayload 0 full - } - Right (Just claimed) <- - Store.runStoreIO storeHandle $ - runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) - claimed ^. #timerId `shouldBe` timerId - Right terminalTimer <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement timerUuid sleepTimerStatusStmt - fmap fst terminalTimer `shouldBe` Just "cancelled" - Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream - Right resolved <- - Store.runStoreIO storeHandle $ - stepExists name wid 0 full - resolved `shouldBe` False - - it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do - let parentName = WorkflowName "gc-live-parent" - parentId = WorkflowId "gp-1" - childName = WorkflowName "gc-child" - childId = WorkflowId "gc-1" - now <- getCurrentTime - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ do - Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing - Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result" - void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now) - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry childName childId (WorkflowCompleted now) - Right held <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - held `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} - Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0) - childStillThere `shouldSatisfy` isJust - Right () <- - Store.runStoreIO storeHandle $ - appendJournalEntry parentName parentId (WorkflowCompleted now) - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt - Right collected <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce - (addUTCTime 1 now) - WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 2} - Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId - parentGone `shouldBe` Nothing - Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId - childGone `shouldBe` Nothing - Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1" - childRows `shouldBe` 0 - - -- One failing deletion used to take the whole batch with it, and the - -- summary claimed everything eligible had been deleted regardless. The - -- sabotage is a workflow id long enough that its derived journal stream - -- name exceeds kiroku's 512-byte limit, so `hardDeleteStream` throws - -- `StreamNameTooLong` every time — no timing, no concurrency. - it "isolates a failing deletion, reports it honestly, and re-scans it" $ \storeHandle -> do - counter <- newIORef (0 :: Int) - let healthyName = WorkflowName "gc-isolated" - healthyId = WorkflowId "gi-1" - sabotagedId = Text.replicate 600 "x" - policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - Right (Completed _) <- - Store.runStoreIO storeHandle $ - runWorkflow healthyName healthyId (demoWorkflow counter) - -- Written directly: a workflow with this id could never journal anything, - -- because the same limit rejects its appends. GC eligibility reads only - -- the instance row, which is exactly the surface under test. - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement (sabotagedId, "gc-sabotaged") insertTerminalGcInstanceStmt - now <- getCurrentTime - Right summary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce (addUTCTime 1 now) policy - summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 1} - -- The healthy workflow was collected despite the other one failing. - Right healthyGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance healthyName healthyId - healthyGone `shouldBe` Nothing - -- The sabotaged one kept its instance row, so it stays eligible: a - -- partially collected workflow converges instead of leaking. - Right nextSummary <- - Store.runStoreIO storeHandle $ - WorkflowGc.gcWorkflowsOnce (addUTCTime 2 now) policy - nextSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 0} - - it "keeps the gc loop alive across a pass it cannot finish" $ \storeHandle -> do - logged <- newIORef ([] :: [Text]) - let sabotagedId = Text.replicate 600 "x" - policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} - -- A bare `forever` loop would report at most once and then die on the - -- error; per-pass isolation keeps it reporting every tick. - waitForTwoPasses = timeout 5_000_000 $ do - let go = do - seen <- readIORef logged - if length seen >= 2 - then pure () - else threadDelay 20_000 >> go - go - Right () <- - Store.runStoreIO storeHandle $ - Store.runTransaction $ - Tx.statement (sabotagedId, "gc-loop-sabotaged") insertTerminalGcInstanceStmt - worker <- - forkIO . void . Store.runStoreIO storeHandle $ - WorkflowGc.runWorkflowGcWorkerWith policy 20_000 (\msg -> modifyIORef' logged (msg :)) - reported <- waitForTwoPasses `finally` killThread worker - reported `shouldBe` Just () - messages <- readIORef logged - messages `shouldSatisfy` all ("stay eligible" `Text.isInfixOf`) - --- | One resume pass over four candidates that exercise every outcome a pass --- can report: one that completes, one that suspends, one whose name is absent --- from the registry, and one that crashes into terminal failure at a ceiling of --- one attempt. Parameterised by @maxConcurrentAdvances@ so the sequential and --- concurrent runs are literally the same scenario. -runMixedResumePass :: Store.KirokuStore -> Int -> IO ResumeSummary -runMixedResumePass storeHandle concurrency = do - healthyCounter <- newIORef (0 :: Int) - let healthyName = WorkflowName "mixed-healthy" - suspendedName = WorkflowName "mixed-suspended" - poisonName = WorkflowName "mixed-poison" - orphanName = WorkflowName "mixed-orphan" - opts = - defaultWorkflowResumeOptions - & #maxAttempts - .~ 1 - & #maxConcurrentAdvances - .~ concurrency - & #logEvent - .~ const (pure ()) - registry = - Map.fromList - [ (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)), - (suspendedName, WorkflowDef (\_ -> neverArmingWorkflow)), - (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) - ] - now <- getCurrentTime - for_ [healthyName, suspendedName, poisonName, orphanName] $ \name -> - Store.runStoreIO - storeHandle - (appendJournalEntry name (WorkflowId "mixed-1") (StepRecorded "seed" (toJSON True) now)) - `shouldReturn` Right () - Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry - readIORef healthyCounter `shouldReturn` 3 - pure summary - -expectedMixedResumeSummary :: ResumeSummary -expectedMixedResumeSummary = - emptyResumeSummary - { discovered = 4, - advanced = 2, - resumed = 3, - completed = 1, - stillSuspended = 1, - unknownName = 1, - failed = 1, - unregisteredNames = Set.singleton "mixed-orphan" - } - --- | Do two recorded execution windows intersect? Used to tell a concurrent --- resume pass from a sequential one without measuring throughput. -windowsOverlap :: [(Text, UTCTime, UTCTime)] -> Bool -windowsOverlap = \case - [(_, startA, endA), (_, startB, endB)] -> startA < endB && startB < endA - _ -> False - --- | Increment a shared counter and return its new value (the step's side --- effect, so replay can be proven by watching the counter). -incrementAndRead :: IORef Int -> IO Int -incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1)) - -forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) () -forceWorkflowLeaseStmt = - preparable - """ - UPDATE keiro.keiro_workflows - SET leased_by = $3, - lease_expires_at = $4, - updated_at = now() - WHERE workflow_id = $1 - AND workflow_name = $2 - """ - ( contrazip4 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - --- | Six numbered steps, each returning its index after bumping a shared --- counter. The counter lets a re-hydration prove the steps short-circuit --- (it stays at 6 when every step is replayed from the journal/snapshot). -countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int] -countingSixSteps counter = - mapM - (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i)) - [1 .. 6] - -newtype Approx = Approx Double - deriving stock (Eq, Show) - -instance ToJSON Approx where - toJSON (Approx d) = toJSON (round d :: Int) - -instance FromJSON Approx where - parseJSON value = do - n <- Aeson.parseJSON value - pure (Approx (fromIntegral (n :: Int))) - -data RejectingRoundTrip = RejectingRoundTrip - deriving stock (Eq, Show) - -instance ToJSON RejectingRoundTrip where - toJSON RejectingRoundTrip = Aeson.String "not-an-object" - -instance FromJSON RejectingRoundTrip where - parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip - --- | A distinguished exception used to simulate a process crash mid-workflow --- (after a step has committed its journal append but before completion). -data SimulatedCrash = SimulatedCrash - deriving stock (Show) - -instance Exception SimulatedCrash - --- | A three-step workflow; each step bumps a shared counter so a resume can --- prove steps short-circuit (the counter only advances for steps that run). -threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) -threeStep counter = do - a <- step (StepName "s1") (liftIO (incrementAndRead counter)) - b <- step (StepName "s2") (liftIO (incrementAndRead counter)) - c <- step (StepName "s3") (liftIO (incrementAndRead counter)) - pure (a, b, c) - -threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int) -threeStepThenSignal counter done = do - result <- threeStep counter - liftIO (putMVar done ()) - pure result - --- | Runs step @"s1"@ (which commits its own journal append) then crashes, so --- the journal is left with one StepRecorded and no WorkflowCompleted. -crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) -crashAfterStep1 counter = do - _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) - _ <- liftIO (throwIO SimulatedCrash) - pure (0, 0, 0) - --- | A workflow with one durable side effect before a switchable failure and --- one durable side effect after it. Resurrection tests use the counter to prove --- the recorded prefix never executes again. -recoverableWorkflow :: - (Workflow :> es, IOE :> es) => - IORef Bool -> - IORef Int -> - Eff es Int -recoverableWorkflow shouldCrash counter = do - _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter)) - crashing <- liftIO (readIORef shouldCrash) - when crashing (liftIO (throwIO SimulatedCrash)) - step (StepName "durable-tail") (liftIO (incrementAndRead counter)) - --- | Awaits an external step, then runs a step that bumps the counter. Used to --- prove the resume worker drives a suspended workflow to completion once its --- awaited step is journaled. -awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -awaitingThenStep counter = do - decision <- awaitStep (StepName "awk:approval") (pure ()) - _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!")) - pure (decision <> "-done") - --- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@ --- unit-valued work steps to a running total, rotating its journal every --- @rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair --- @(runningTotal, stepsDoneGlobally)@ so each generation knows the global --- progress; @genDone@ counts steps within the /current/ generation to bound it. --- Each work step bumps @counter@ exactly once (proving rotation neither drops --- nor double-counts) and returns 1, so the final total equals @total@. --- --- Step names are the global step index (@w0@, @w1@, …), so they are unique --- within each generation's journal and replay-stable. Note the regression --- direction: on a tree where 'continueAsNew' did not rotate, this body would put --- all @total@ steps on generation 0's single journal and the per-generation --- @<= K@ bound below would fail for @total > K@. -rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int -rollingTotal counter rotateEvery total = do - (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int) - go acc0 done0 0 - where - go acc done genDone - | done >= total = pure acc -- all global work done: this generation completes - | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward - | otherwise = do - n <- - step - (StepName ("w" <> Text.pack (show done))) - (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int))) - go (acc + n) (done + 1) (genDone + 1) - --- The patch id under test (EP-49). -fraudPatchId :: PatchId -fraudPatchId = PatchId "fraud-check-v2" - --- | The workflow BEFORE the patch shipped: reserve, then await an external step --- (so an instance can be left in flight, mid-journal, with one ordinary step --- recorded and no completion). Used to create the in-flight instance. -prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -prePatchWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight - pure "old-done" - --- | The workflow AFTER the patch shipped: the same first step, then a --- patch-gated cross-cutting branch. The in-flight instance (which already --- journaled reserve-inventory under the pre-patch code) must observe False and --- take the OLD branch; a fresh instance must observe True and take the NEW branch. -postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -postPatchWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text -postPatchAfterSuspendWorkflow counter = do - _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text -prePatchWakeOnlyWorkflow = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - pure "old-done" - -postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text -postPatchWakeOnlyWorkflow = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - -rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text -rotatingPatchWorkflow = do - seed <- restoreSeed (0 :: Int) - if seed < 1 - then continueAsNew (seed + 1) - else do - useNew <- patch fraudPatchId - if useNew - then step (StepName "new-charge") (pure "new-branch") - else step (StepName "old-charge") (pure "old-branch") - --- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then --- runs a step that fills @done@ — so a test can observe the exact moment the --- workflow resumes to completion. Awaiting first means the journal is empty until --- the external gate append, which is what makes the instance discoverable by the --- resume worker (the gate's StepRecorded is the first index row). -gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text -gateThenSignal done = do - (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) - _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ()) - pure "resumed" - --- | A two-step workflow whose steps each bump a shared counter. --- | Two steps whose names collided under the codepoint-truncating id --- derivation: U+0101 and U+0001 both hashed as the single byte @0x01@, so the --- second step's journal append was rejected as a duplicate event id. -collidingStepWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) -collidingStepWorkflow counter = do - a <- step (StepName "\x0101") (liftIO (incrementAndRead counter)) - b <- step (StepName "\SOH") (liftIO (incrementAndRead counter)) - pure (a, b) - -demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) -demoWorkflow counter = do - a <- step (StepName "first") (liftIO (incrementAndRead counter)) - b <- step (StepName "second") (liftIO (incrementAndRead counter)) - pure (a, b) - --- | A workflow that immediately awaits a step nothing ever arms — used to --- exercise the suspend path and external completion. -neverArmingWorkflow :: (Workflow :> es) => Eff es Int -neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ()) - --- | The awakeable validation workflow: allocate a durable promise, suspend on --- it, and (once signalled) append "!" to the payload through a recorded step. -approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text -approvalFlowWithId ref = do - (aid, await) <- awakeableNamed (StepName "approval") - liftIO (writeIORef ref (Just aid)) - v <- await - step (StepName "use") (pure (v <> "!")) - -unicodeApprovalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text -unicodeApprovalFlowWithId ref = do - (aid, await) <- awakeableNamed (StepName "\x627F\x8A8D") - liftIO (writeIORef ref (Just aid)) - v <- await - step (StepName "use") (pure (v <> "!")) - -publishAwakeableBeforeAwait :: - forall es. - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es () -publishAwakeableBeforeAwait ref = do - (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") - _ <- - step (StepName "publish") $ do - liftIO (writeIORef ref (Just aid)) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -awaitPublishedAwakeable :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es Text -awaitPublishedAwakeable ref = do - (aid, await) <- awakeableNamed (StepName "gate") - _ <- - step (StepName "publish") $ do - liftIO (writeIORef ref (Just aid)) - await - -snapshotUnsignalledAwakeable :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es Text -snapshotUnsignalledAwakeable ref = do - (aid, await) <- awakeableNamed (StepName "gate") - liftIO (writeIORef ref (Just aid)) - await - -snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text -snapshotShadowedAwakeable = do - (aid, await) <- awakeableNamed (StepName "gate") - _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) - await - -snapshotStaleAwakeablePhaseOne :: - forall es. - (Workflow :> es, Store :> es, IOE :> es) => - IORef (Maybe AwakeableId) -> - Eff es () -snapshotStaleAwakeablePhaseOne ref = do - (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") - liftIO (writeIORef ref (Just aid)) - _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text -snapshotStaleAwakeablePhaseTwo = do - (_aid, await) <- awakeableNamed (StepName "gate") - _ <- step (StepName "mid") (pure ()) - await - -snapshotStaleChildPhaseOne :: - (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) => - WorkflowId -> - Eff es () -snapshotStaleChildPhaseOne childWid = do - _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow - _ <- - step (StepName "drive") $ - void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow) - (_ :: ()) <- awaitStep (StepName "hold") (pure ()) - pure () - -snapshotStaleChildPhaseTwo :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> - Eff es Text -snapshotStaleChildPhaseTwo childWid = do - h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow - _ <- step (StepName "drive") (pure ()) - awaitChild h - -readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId -readRequiredAwakeableId ref = - readIORef ref >>= \case - Just aid -> pure aid - Nothing -> fail "workflow did not allocate an awakeable id" - -uuidLiteral :: String -> UUID -uuidLiteral raw = - case fromString raw of - Just uuid -> uuid - Nothing -> error ("invalid UUID literal in test: " <> raw) - --- | A two-step workflow with a durable sleep between the steps. The sleep's --- name and delay are parameters so one helper drives both the zero-delta and --- the real-time tests. -sleepDemoNamed :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int) -sleepDemoNamed counter sName delta = do - a <- step (StepName "a") (liftIO (incrementAndRead counter)) - sleepNamed sName delta - b <- step (StepName "b") (liftIO (incrementAndRead counter)) - pure (a, b) - --- | Two sleeps on one generation with a step between them: the first is due --- immediately, the second far in the future. Firing the first and resuming --- moves the live wake hint onto the second sleep, which is the state a stale --- re-fire of the first timer must not disturb. -twoSleepWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef Int -> Eff es Int -twoSleepWorkflow counter = do - sleepNamed (StepName "first") 0 - n <- step (StepName "mid") (liftIO (incrementAndRead counter)) - sleepNamed (StepName "second") 3600 - pure n - -rollingSleepWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef Int -> Eff es Int -rollingSleepWorkflow counter = do - seed <- restoreSeed (0 :: Int) - _ <- step (StepName "work") (liftIO (incrementAndRead counter)) - if seed < 2 - then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1) - else pure seed - -rollingAwakeableWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - IORef [AwakeableId] -> Eff es Text -rollingAwakeableWorkflow idsRef = do - seed <- restoreSeed (0 :: Int) - (aid, await) <- awakeableNamed (StepName "gate") - liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid])) - value <- await - if seed < 1 - then continueAsNew (seed + 1) - else step (StepName "use") (pure value) - -rotatingParentWorkflow :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> Eff es Text -rotatingParentWorkflow childWid = do - seed <- restoreSeed (0 :: Int) - h <- spawnChild (WorkflowName "ship") childWid shipWorkflow - result <- awaitChild h - if seed < 1 - then continueAsNew (seed + 1) - else pure result - -failedChildBeforeRotation :: - (Workflow :> es, Store :> es) => - WorkflowId -> - Eff es Text -failedChildBeforeRotation childWid = do - _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow - awaitStep (StepName "rotation-gate") (pure ()) - -rotatePastFailedChild :: - (Workflow :> es, Store :> es) => - WorkflowId -> - Eff es Text -rotatePastFailedChild childWid = do - _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow - continueAsNew () - -catchFailedChildAfterRotation :: - (Workflow :> es, Store :> es, IOE :> es) => - WorkflowId -> - Eff es Text -catchFailedChildAfterRotation childWid = do - child <- spawnChild (WorkflowName "ship") childWid shipWorkflow - EffException.catch - (awaitChild child) - (\(WorkflowChildFailed _ _ reason) -> pure reason) - --- | A workflow that records one step, then suspends on an await — so it has a --- step row but no completion marker (the unfinished-discovery case). -stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int -stepThenAwaitWorkflow counter = do - _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) - awaitStep (StepName "awk:wait") (pure ()) - --- | Two sequential gates. Journaling the first makes the workflow discoverable --- again; the resulting re-invocation replays past it and parks on the second, --- so the run is re-invoked and still suspends. -twoGateWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int -twoGateWorkflow counter = do - _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) - (_ :: ()) <- awaitStep (StepName "awk:first") (pure ()) - awaitStep (StepName "awk:second") (pure ()) - --- | A two-step child workflow used in the child-workflow tests. -shipWorkflow :: (Workflow :> es) => Eff es Text -shipWorkflow = do - a <- step (StepName "pack") (pure ("packed" :: Text)) - b <- step (StepName "label") (pure (a <> "+labelled")) - pure b - --- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and --- then records a @notify@ step. Parametrised by child id so each test isolates --- its own child journal. -parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text -parentWorkflow childWid = do - h <- spawnChild (WorkflowName "ship") childWid shipWorkflow - result <- awaitChild h - _ <- step (StepName "notify") (pure ("done:" <> result)) - pure ("done:" <> result) - -jsonObjectChildWorkflow :: Eff es Aeson.Value -jsonObjectChildWorkflow = - pure (object ["cancelled" Aeson..= True]) - -jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value -jsonObjectParentWorkflow childWid = do - h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow - result <- awaitChild h - _ <- step (StepName "json-notify") (pure ()) - pure result - --- | The failure counterpart of 'selfCancellingWorkflow': step one's action --- writes this workflow's own terminal failure marker, standing in for the --- resume worker marking it failed while another runner is mid-run. -selfFailingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int -selfFailingWorkflow name wid counter = do - _ <- - step (StepName "one") $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (WorkflowFailed "ceiling reached" now) - liftIO (incrementAndRead counter) - step (StepName "two") (liftIO (incrementAndRead counter)) - -selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int -selfCancellingWorkflow name wid counter = do - _ <- step (StepName "one") (liftIO (incrementAndRead counter)) - _ <- - step (StepName "two") $ do - now <- liftIO getCurrentTime - appendJournalEntry name wid (WorkflowCancelled now) - liftIO (incrementAndRead counter) - step (StepName "three") (liftIO (incrementAndRead counter)) - -nominalDays :: Int -> NominalDiffTime -nominalDays n = fromIntegral n * 86400 - -attrKeyText :: AttributeKey Text -> Text -attrKeyText = unkey - -attrKeyTextInt64 :: AttributeKey Int64 -> Text -attrKeyTextInt64 = unkey - -textAttr :: Attributes -> Text -> Maybe Text -textAttr attrs name = case lookupAttribute attrs name of - Just (AttributeValue (TextAttribute t)) -> Just t - _ -> Nothing - -intAttr :: Attributes -> Text -> Maybe Int64 -intAttr attrs name = case lookupAttribute attrs name of - Just (AttributeValue (IntAttribute n)) -> Just n - _ -> Nothing - --- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the --- mutable span fields (name, attributes, status) live behind the --- @spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan', --- so the tests read that reference once after the span ends and assert on --- this flat record. -data CapturedSpan = CapturedSpan - { csName :: Text, - csKind :: SpanKind, - csAttributes :: Attributes, - csStatus :: SpanStatus, - csContext :: SpanContext, - csParent :: Maybe Span - } - -captureSpan :: ImmutableSpan -> IO CapturedSpan -captureSpan sp = do - hot <- readIORef (spanHot sp) - pure - CapturedSpan - { csName = hotName hot, - csKind = spanKind sp, - csAttributes = hotAttributes hot, - csStatus = hotStatus hot, - csContext = spanContext sp, - csParent = spanParent sp - } - --- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an --- incrementing offset. The publisher pushes records here; the consumer --- drains the MVar. There is no real broker — the goal of the fixture is --- to validate that the keiro envelope and outbox/inbox semantics --- compose correctly across two isolated PostgreSQL contexts. -newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord])) - -newKafkaTopic :: IO KafkaTopic -newKafkaTopic = KafkaTopic <$> newMVar (0, []) - -kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m () -kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do - let record = OutboxKafka.outboxRowToKafkaRecord row - headersText = - [ (TE.decodeUtf8 name, TE.decodeUtf8 value) - | (name, value) <- record ^. #headers - ] - now <- getCurrentTime - modifyMVar ref $ \(nextOffset, acc) -> - let inbound = - InboxKafka.KafkaInboundRecord - { topic = record ^. #topic, - partition = 0, - offset = nextOffset, - key = fmap TE.decodeUtf8 (record ^. #key), - payload = record ^. #payload, - headers = headersText, - receivedAt = now - } - in pure ((nextOffset + 1, inbound : acc), ()) - -kafkaTopicPublish :: - forall es. - (IOE :> es) => - KafkaTopic -> - OutboxRow -> - Eff es PublishOutcome -kafkaTopicPublish topic row = do - kafkaTopicAccept topic row - pure PublishSucceeded - -perRow :: - (OutboxRow -> Eff es PublishOutcome) -> - [OutboxRow] -> - Eff es [(OutboxId, PublishOutcome)] -perRow publish rows = - traverse publishOne rows - where - publishOne row = do - outcome <- publish row - pure (row ^. #outboxId, outcome) - -drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord] -drainKafkaTopic (KafkaTopic ref) = do - (_, acc) <- readMVar ref - pure (reverse acc) - -redeliverWithDifferentOffset :: - InboxKafka.KafkaInboundRecord -> - InboxKafka.KafkaInboundRecord -redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000 - -data ConsumeResult a - = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError - | ConsumePolicyUnsatisfied !InboxError - | ConsumeApplied !(InboxResult a) - deriving stock (Eq, Show) - --- | A worker-shaped consumer: decode the Kafka record into an --- IntegrationEvent and run it through the inbox. -consumeAndApply :: - forall es. - (IOE :> es, Store :> es) => - InboxKafka.KafkaInboundRecord -> - (IntegrationEvent -> Tx.Transaction ()) -> - Eff es (ConsumeResult ()) -consumeAndApply record handler = - case InboxKafka.integrationEventFromKafka record of - Left err -> pure (ConsumeDecodeFailed err) - Right (event, kafkaRef) -> do - result <- - runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler - case result of - Left err -> pure (ConsumePolicyUnsatisfied err) - Right applied -> pure (ConsumeApplied applied) - -billingReactionHandler :: IntegrationEvent -> Tx.Transaction () -billingReactionHandler event = case decodeJsonIntegrationEvent event of - Left _ -> Tx.condemn - Right (OrderSubmittedPayload orderId quantity) -> - Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt - -loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction () -loggingReactionHandler _ event = do - -- The cross-context test only needs the (eventType, key) pair, not - -- the decoded payload. - let key = fromMaybe "" (event ^. #key) - Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt - -insertReceivedOrderStmt :: Statement (Text, Int64) () -insertReceivedOrderStmt = - preparable - """ - INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2) - ON CONFLICT (order_id) DO NOTHING - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int8)) - ) - D.noResult - -billingReceivedOrdersCountStmt :: Statement () Int -billingReceivedOrdersCountStmt = - preparable - "SELECT COUNT(*)::bigint FROM billing_received_orders" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - -appendBillingEventLogStmt :: Statement (Text, Text, Text) () -appendBillingEventLogStmt = - preparable - "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)" - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - D.noResult - -billingEventLogStmt :: Statement () [(Text, Text)] -billingEventLogStmt = - preparable - "SELECT event_type, order_id FROM billing_event_log ORDER BY seq" - E.noParams - ( D.rowList - ( (,) - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - ) - ) - -orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent -orderSubmittedEnvelope orderId quantity messageId = - encodeJsonIntegrationEvent - ( sampleIntegrationEnvelope - & #messageId - .~ messageId - & #eventType - .~ "OrderSubmitted" - & #key - .~ Just orderId - ) - (OrderSubmittedPayload orderId quantity) - -orderCancelledEnvelope :: Text -> Text -> IntegrationEvent -orderCancelledEnvelope orderId messageId = - sampleIntegrationEnvelope - & #messageId - .~ messageId - & #eventType - .~ "OrderCancelled" - & #key - .~ Just orderId - & #payloadBytes - .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}") - & #contentType - .~ ApplicationJson - -inboxTestCounterInsertStmt :: Statement Text () -inboxTestCounterInsertStmt = - preparable - "INSERT INTO inbox_test_counter (message_id) VALUES ($1)" - (E.param (E.nonNullable E.text)) - D.noResult - -inboxTestCounterCountStmt :: Statement () Int -inboxTestCounterCountStmt = - preparable - "SELECT COUNT(*)::bigint FROM inbox_test_counter" - E.noParams - (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) - -sampleProducer :: IntegrationProducer () -sampleProducer = - IntegrationProducer - { name = "ordering-integration-producer", - source = "ordering", - messageIdPrefix = "msg", - mapEvent = \_recorded () -> Just sampleDraft - } - -sampleDraft :: IntegrationEventDraft -sampleDraft = - IntegrationEventDraft - { destination = "billing.orders.v1", - key = Just "order-123", - eventType = "OrderSubmitted", - schemaVersion = 1, - contentType = ApplicationJson, - schemaReference = Nothing, - sourceEventId = Nothing, - sourceGlobalPosition = Nothing, - payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", - occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), - causationId = Nothing, - correlationId = Nothing, - traceContext = Nothing, - attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)]) - } - -sampleOutboxRow :: IntegrationEvent -> OutboxRow -sampleOutboxRow event = - OutboxRow - { outboxId = OutboxId outboxUuid1, - event, - status = OutboxPending, - attemptCount = 0, - nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), - lastError = Nothing, - publishedAt = Nothing, - rejectedAt = Nothing, - rejection = Nothing, - createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), - updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) - } - -backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () -backdateOutboxUpdatedAt oid timestamp = - Store.runTransaction $ - Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt - -backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) () -backdateOutboxUpdatedAtStmt = - preparable - "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1" - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () -backdateOutboxPublishedAt oid timestamp = - Store.runTransaction $ - Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt - -backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) () -backdateOutboxPublishedAtStmt = - preparable - "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1" - ( contrazip2 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - ) - D.noResult - -outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID -outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 1" -outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 2" -outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 3" -outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of - Just uuid -> uuid - Nothing -> error "invalid outbox uuid 4" - -outboxIdFromOrdinal :: Word64 -> OutboxId -outboxIdFromOrdinal n = - OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n)) - -uniqueIds :: (Eq a) => [a] -> [a] -uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) [] - -data OrderSubmittedPayload = OrderSubmittedPayload - { orderId :: !Text, - quantity :: !Int - } - deriving stock (Generic, Eq, Show) - -instance ToJSON OrderSubmittedPayload where - toJSON = genericToJSON (aesonPrefix camelCase) - toEncoding = genericToEncoding (aesonPrefix camelCase) - -instance FromJSON OrderSubmittedPayload where - parseJSON = genericParseJSON (aesonPrefix camelCase) - -sampleIntegrationEnvelope :: IntegrationEvent -sampleIntegrationEnvelope = - IntegrationEvent - { messageId = "018f0f18-17aa-7000-8000-0000000000aa", - source = "ordering", - destination = "billing.orders.v1", - key = Just "order-123", - eventType = "OrderSubmitted", - schemaVersion = 1, - contentType = ApplicationJson, - schemaReference = - Just - SchemaReference - { registry = Just "https://schemas.example/registry", - subject = Just "billing.orders.v1.OrderSubmitted", - version = Just 1, - schemaId = Just 42, - fingerprint = Just "sha256:abc123" - }, - sourceEventId = Just (EventId integrationSourceEventUuid), - sourceGlobalPosition = Just (GlobalPosition 42), - payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", - occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), - causationId = Just (EventId integrationCausationUuid), - correlationId = Just (EventId integrationCorrelationUuid), - traceContext = - Just - TraceContext - { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01", - tracestate = Just "rojo=00f067aa0ba902b7" - }, - attributes = Nothing - } - -integrationSourceEventUuid :: UUID -integrationSourceEventUuid = - case fromString "018f0f18-17aa-7000-8000-000000000003" of - Just uuid -> uuid - Nothing -> error "invalid integration source event UUID" - -integrationCausationUuid :: UUID -integrationCausationUuid = - case fromString "018f0f18-17aa-7000-8000-000000000004" of - Just uuid -> uuid - Nothing -> error "invalid integration causation UUID" - -integrationCorrelationUuid :: UUID -integrationCorrelationUuid = - case fromString "018f0f18-17aa-7000-8000-000000000005" of - Just uuid -> uuid - Nothing -> error "invalid integration correlation UUID" - -data OrderStream - -data OrderEvent - = OrderPlaced !Text !Int - deriving stock (Generic, Eq, Show) - -data OrderState - = Idle - deriving stock (Generic, Eq, Show) - -data OrderCommand - = PlaceOrder - deriving stock (Generic, Eq, Show) - -orderCodec :: Codec OrderEvent -orderCodec = - Codec - { eventTypes = EventType "OrderPlaced" :| [], - eventType = \case - OrderPlaced {} -> EventType "OrderPlaced", - schemaVersion = 2, - encode = \case - OrderPlaced orderId quantity -> - object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity], - decode = parseOrderPlaced, - upcasters = [(1, const upcastOrderPlacedV1)] - } - -gappyCodec :: Codec OrderEvent -gappyCodec = - Codec - { eventTypes = orderCodec ^. #eventTypes, - eventType = orderCodec ^. #eventType, - schemaVersion = 4, - encode = orderCodec ^. #encode, - decode = orderCodec ^. #decode, - upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)] - } - -parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent -parseOrderPlaced _ value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "OrderPlaced" $ \objectValue -> - OrderPlaced - <$> objectValue .: "orderId" - <*> objectValue .: "quantity" - -upcastOrderPlacedV1 :: Value -> Either Text Value -upcastOrderPlacedV1 value = - case parseEither parser value of - Right migrated -> Right migrated - Left message -> Left (fromStringLiteral message) - where - parser = withObject "OrderPlacedV1" $ \objectValue -> do - orderId <- objectValue .: "orderId" - quantity <- objectValue .: "qty" - pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)]) - -metadataForOrDie :: Int -> Maybe Value -> Value -metadataForOrDie version existing = - either (error . show) id (metadataFor version existing) - -emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent -emptyTransducer = - SymTransducer - { edgesOut = \_ -> [], - initial = Idle, - initialRegs = RNil, - isFinal = \_ -> True - } - -type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent - -type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent - -type SnapshotCounterRegs = '[ '("lastAmount", Int)] - -type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)] - -type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent - -type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent - -type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent - -type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent - -data CounterCommand - = Add !Int - deriving stock (Generic, Eq, Show) - -data SkipCommand - = SAdd !Int - | SSkip - deriving stock (Generic, Eq, Show) - -data CounterEvent - = CounterAdded !Int - | CounterAudited !Int - deriving stock (Generic, Eq, Show) - -data CounterState - = Counting - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - deriving anyclass (FromJSON, ToJSON) - -instance CanonicalStateShape CounterState - -data CounterStateV2 - = CountingV2 - | PausedV2 - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - deriving anyclass (FromJSON, ToJSON) - -instance CanonicalStateShape CounterStateV2 - -data DrainState - = Draining - | Drained - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -data PartialSnapshotState - = SnapshotEncodable - | SnapshotEncodeBomb - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -instance CanonicalStateShape PartialSnapshotState - -instance ToJSON PartialSnapshotState where - toJSON SnapshotEncodable = Aeson.String "encodable" - toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded" - -instance FromJSON PartialSnapshotState where - parseJSON = Aeson.withText "PartialSnapshotState" $ \case - "encodable" -> pure SnapshotEncodable - "bomb" -> pure SnapshotEncodeBomb - other -> fail ("unknown partial snapshot state: " <> Text.unpack other) - -counterEventStreamDef :: CounterEventStream -counterEventStreamDef = - EventStream - { transducer = counterTransducer, - initialState = Counting, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -counterEventStream :: ValidatedCounterEventStream -counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef - -auditedCounterEventStream :: ValidatedCounterEventStream -auditedCounterEventStream = - mkEventStreamOrThrow - "counter-audited-only" - (counterEventStreamDef & #transducer .~ auditedCounterTransducer) - -auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -auditedCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - -noOpCounterEventStreamDef :: CounterEventStream -noOpCounterEventStreamDef = - counterEventStreamDef & #transducer .~ noOpCounterTransducer - -noOpCounterEventStream :: ValidatedCounterEventStream -noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef - -counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -counterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - -noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -noOpCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - -multiCounterEventStreamDef :: CounterEventStream -multiCounterEventStreamDef = - counterEventStreamDef & #transducer .~ multiCounterTransducer - -multiCounterEventStream :: ValidatedCounterEventStream -multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef - -multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -multiCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = - [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), - pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - --- | Both guards match at runtime but remain outside keiki's conservative pure --- overlap fragment. Distinct head event constructors keep inversion unambiguous, --- so this is a validated stream that exercises the runtime step witness. -ambiguousCounterEventStreamDef :: CounterEventStream -ambiguousCounterEventStreamDef = - counterEventStreamDef & #transducer .~ ambiguousCounterTransducer - -ambiguousCounterEventStream :: ValidatedCounterEventStream -ambiguousCounterEventStream = - mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef - -ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -ambiguousCounterTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = ambiguousGuard, - update = UKeep, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = ambiguousGuard, - update = UKeep, - output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ] - } - where - ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot) - -snapshotCounterEventStreamDef :: SnapshotCounterEventStream -snapshotCounterEventStreamDef = - EventStream - { transducer = snapshotCounterTransducer, - initialState = Counting, - initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Every 2, - stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1) - } - -partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent -partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef - -partialSnapshotEventStreamDef :: PartialSnapshotEventStream -partialSnapshotEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \_ -> - [ Edge - { guard = matchInCtor addCtor, - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount), - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = SnapshotEncodeBomb, - mode = Keiki.Live - } - ], - initial = SnapshotEncodable, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - }, - initialState = SnapshotEncodable, - initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Every 1, - stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1) - } - -uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream -uninitializedSnapshotEventStreamDef = - initializedSnapshotEventStreamDef - & #initialRegisters - .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)]) - -initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream -initializedSnapshotEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \case Counting -> [], - initial = Counting, - initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), - isFinal = \_ -> False - }, - initialState = Counting, - initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Every 2, - stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1) - } - -snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef - -snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -snapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount), - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - } - -foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -foldV1SnapshotCounterEventStream = - mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef - -foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream -foldV1SnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef - { transducer = foldV1SnapshotCounterTransducer, - stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - ) - } - -foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -foldV2SnapshotCounterEventStream = - mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef - -foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream -foldV2SnapshotCounterEventStreamDef = - foldV1SnapshotCounterEventStreamDef - { transducer = foldV2SnapshotCounterTransducer, - snapshotPolicy = Every 1, - stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v2") - 1 - ) - } - -foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream -foldV2WithoutFingerprintBumpEventStream = - mkEventStreamOrThrow - "snapshot-counter-fold-v2-without-fingerprint-bump" - foldV2WithoutFingerprintBumpEventStreamDef - -foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream -foldV2WithoutFingerprintBumpEventStreamDef = - foldV2SnapshotCounterEventStreamDef - { stateCodec = - Just - ( defaultStateCodecWithFold - @SnapshotCounterRegs - @CounterState - (FoldVersion "fold-v1") - 1 - ) - } - -foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldV1SnapshotCounterTransducer = - foldSnapshotCounterTransducer - (inpCtor addCtor #amount) - -foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldV2SnapshotCounterTransducer = - foldSnapshotCounterTransducer - (inpCtor addCtor #amount K..+ lit 1) - -foldSnapshotCounterTransducer :: - Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int -> - SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -foldSnapshotCounterTransducer nextLastAmount = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = - PAnd - (matchInCtor addCtor) - (inpCtor addCtor #amount K..< lit 100), - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - nextLastAmount, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = - PAnd - (matchInCtor addCtor) - ( PAnd - (inpCtor addCtor #amount K..>= lit 100) - ( inpCtor addCtor #amount - .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100) - ) - ), - update = UKeep, - output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - } - -multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -multiSnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef - & #transducer - .~ multiSnapshotCounterTransducer - & #snapshotPolicy - .~ Every 1 - -multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef - -multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -multiSnapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount), - output = - [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), - pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - } - -guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -guardedSnapshotCounterEventStreamDef = - snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer - -guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef - -guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -guardedSnapshotCounterTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = - PAnd - (matchInCtor addCtor) - (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int)), - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount), - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - } - --- | A deliberately replay-unsafe stream: its single edge is an ε-edge --- (empty @output@) whose @update@ reads the command's @amount@. Because --- the edge emits no event, that command field cannot be recovered on --- replay, so keiki's hidden-input check flags it. Used to prove --- 'validateEventStream' / 'mkEventStream' reject an unsafe stream. -brokenHiddenInputEventStream :: SnapshotCounterEventStream -brokenHiddenInputEventStream = - snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer - -brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -brokenHiddenInputTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (inpCtor addCtor #amount), - output = [], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RCons (Proxy @"lastAmount") 0 RNil, - isFinal = \_ -> False - } - --- | A multi-event edge whose tail carries the command field omitted from its --- head. The union of the outputs covers @amount@, but replay commits to an edge --- by inverting only the head, so the stored chain cannot reconstruct @Add@. -headUnrecoverableEventStreamDef :: CounterEventStream -headUnrecoverableEventStreamDef = - counterEventStreamDef & #transducer .~ headUnrecoverableTransducer - -headUnrecoverableEventStream :: ValidatedCounterEventStream -headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef - -headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -headUnrecoverableTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = - [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil), - pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) - ], - target = Counting, - mode = Keiki.Live - } - ] - } - --- | Two edges share a head wire constructor, so one stored event can invert --- through both. The double-negated guard is true at runtime but deliberately --- outside keiki's pure overlap fragment, isolating the inversion warning from --- the separate conservative determinism check. -inversionAmbiguousEventStreamDef :: CounterEventStream -inversionAmbiguousEventStreamDef = - counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer - -inversionAmbiguousEventStream :: ValidatedCounterEventStream -inversionAmbiguousEventStream = - case mkEventStreamWith - Keiki.defaultValidationOptions {Keiki.checkInversionAmbiguity = False} - "counter-inversion-ambiguous" - inversionAmbiguousEventStreamDef of - Right validated -> validated - Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings) - -inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -inversionAmbiguousTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ ambiguousEdge, - ambiguousEdge - ] - } - where - ambiguousEdge = - Edge - { guard = PAnd (matchInCtor addCtor) (PNot PBot), - update = UKeep, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - --- | This edge reads @Add.amount@ while guarded only by @PTop@. A different --- command constructor would reach the partial projection and crash instead of --- being rejected. -unguardedInputReadEventStreamDef :: CounterEventStream -unguardedInputReadEventStreamDef = - counterEventStreamDef & #transducer .~ unguardedInputReadTransducer - -unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent -unguardedInputReadTransducer = - counterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = PTop, - update = UKeep, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - } - ] - } - --- | A silent self-loop that writes a register. With no emitted event the --- write cannot be reconstructed from the durable log. -stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream -stateChangingEpsilonEventStreamDef = - snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer - -stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent -stateChangingEpsilonTransducer = - snapshotCounterTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor addCtor, - update = - USet - (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) - (Keiki.lit 0), - output = [], - target = Counting, - mode = Keiki.Live - } - ] - } - -type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent - -silentMoveEventStreamDef :: SilentMoveEventStream -silentMoveEventStreamDef = - EventStream - { transducer = silentMoveTransducer, - initialState = Draining, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent -silentMoveTransducer = - SymTransducer - { edgesOut = \case - Draining -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [], - target = Drained, - mode = Keiki.Live - } - ] - Drained -> [], - initial = Draining, - initialRegs = RNil, - isFinal = (== Drained) - } - -isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool -isStateChangingEpsilon = \case - Keiki.StateChangingEpsilon {} -> True - _ -> False - -expectValidationWarning :: - (Bounded s, Enum s, Ord s, Show s) => - Text -> - Text -> - EventStream (HsPred rs ci) rs s ci co -> - Expectation -expectValidationWarning label prefix eventStream = - case mkEventStream label eventStream of - Left warnings -> do - map eswStreamLabel warnings `shouldSatisfy` all (== label) - map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix) - Right _ -> - expectationFailure - ( "expected mkEventStream to reject " - <> Text.unpack label - <> " with warning prefix " - <> Text.unpack prefix - ) - -type AddFields = '[ '("amount", Int)] - -type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent - -type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent - -data SilentChoiceCommand - = RejectSilently - | NoOpSilently - | UnmatchedSilently - deriving stock (Generic, Eq, Show) - -data CoordinatorCommand - = CoordinatorAccept !Int - | CoordinatorReject !Text - | CoordinatorNoOp !Text - | CoordinatorUnmatched - deriving stock (Generic, Eq, Show) - -data DomainDispatchInput = DomainDispatchInput !Text ![CoordinatorCommand] - deriving stock (Generic, Eq, Show) - -type SilentChoiceEventStream = EventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent - -type ValidatedSilentChoiceEventStream = ValidatedEventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent - -type CoordinatorEventStream = EventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent - -type ValidatedCoordinatorEventStream = ValidatedEventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent - -type RetryDecisionEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent - -type ValidatedRetryDecisionEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent - -skipEventStream :: ValidatedSkipEventStream -skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef - -skipEventStreamDef :: SkipEventStream -skipEventStreamDef = - EventStream - { transducer = skipTransducer, - initialState = Counting, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -silentChoiceEventStream :: ValidatedSilentChoiceEventStream -silentChoiceEventStream = mkEventStreamOrThrow "silent-choice-command" silentChoiceEventStreamDef - -silentChoiceEventStreamDef :: SilentChoiceEventStream -silentChoiceEventStreamDef = - EventStream - { transducer = silentChoiceTransducer, - initialState = Counting, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -retryDecisionEventStream :: ValidatedRetryDecisionEventStream -retryDecisionEventStream = mkEventStreamOrThrow "retry-domain-decision" retryDecisionEventStreamDef - -retryDecisionEventStreamDef :: RetryDecisionEventStream -retryDecisionEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \case - Draining -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], - target = Drained, - mode = Keiki.Live - } - ] - Drained -> - [ Edge - { guard = matchInCtor addCtor, - update = UKeep, - output = [], - target = Drained, - mode = Keiki.Live - } - ], - initial = Draining, - initialRegs = RNil, - isFinal = const False - }, - initialState = Draining, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -coordinatorEventStream :: ValidatedCoordinatorEventStream -coordinatorEventStream = mkEventStreamOrThrow "coordinator-domain" coordinatorEventStreamDef - -coordinatorEventStreamDef :: CoordinatorEventStream -coordinatorEventStreamDef = - EventStream - { transducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor coordinatorAcceptCtor, - update = UKeep, - output = [pack coordinatorAcceptCtor counterAddedCtor (inpCtor coordinatorAcceptCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = matchInCtor coordinatorRejectCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = matchInCtor coordinatorNoOpCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = const False - }, - initialState = Counting, - initialRegisters = RNil, - eventCodec = counterCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - -type CoordinatorMessageFields = '[ '("message", Text)] - -coordinatorAcceptCtor :: InCtor CoordinatorCommand AddFields -coordinatorAcceptCtor = - Keiki.unavailableInCtor - "CoordinatorAccept" - (\case CoordinatorAccept amount -> Just (RCons Proxy amount RNil); _ -> Nothing) - (\case RCons _ amount RNil -> CoordinatorAccept amount) - -coordinatorRejectCtor :: InCtor CoordinatorCommand CoordinatorMessageFields -coordinatorRejectCtor = - Keiki.unavailableInCtor - "CoordinatorReject" - (\case CoordinatorReject message -> Just (RCons Proxy message RNil); _ -> Nothing) - (\case RCons _ message RNil -> CoordinatorReject message) - -coordinatorNoOpCtor :: InCtor CoordinatorCommand CoordinatorMessageFields -coordinatorNoOpCtor = - Keiki.unavailableInCtor - "CoordinatorNoOp" - (\case CoordinatorNoOp message -> Just (RCons Proxy message RNil); _ -> Nothing) - (\case RCons _ message RNil -> CoordinatorNoOp message) - -silentChoiceTransducer :: SymTransducer (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent -silentChoiceTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor rejectSilentlyCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = matchInCtor noOpSilentlyCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - -rejectSilentlyCtor :: InCtor SilentChoiceCommand '[] -rejectSilentlyCtor = - Keiki.unavailableInCtor - "RejectSilently" - (\case RejectSilently -> Just RNil; _ -> Nothing) - (\RNil -> RejectSilently) - -noOpSilentlyCtor :: InCtor SilentChoiceCommand '[] -noOpSilentlyCtor = - Keiki.unavailableInCtor - "NoOpSilently" - (\case NoOpSilently -> Just RNil; _ -> Nothing) - (\RNil -> NoOpSilently) - -multiCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text -multiCounterDomainHandler = - DomainCommandHandler - { eventStream = multiCounterEventStream, - classifySilent = \_ -> error "multiCounterDomainHandler: eventful edge classified as silent" - } - -ambiguousCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text -ambiguousCounterDomainHandler = - DomainCommandHandler - { eventStream = ambiguousCounterEventStream, - classifySilent = \_ -> error "ambiguousCounterDomainHandler: no edge should be selected" - } - -silentChoiceDomainHandler :: DomainCommandHandler (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent Text Text -silentChoiceDomainHandler = - DomainCommandHandler - { eventStream = silentChoiceEventStream, - classifySilent = \SilentCommandContext {command = selectedCommand, selectedEdge} -> - case (selectedCommand, Keiki.edgeIndex selectedEdge) of - (RejectSilently, 0) -> SilentRejected "edge-0: rejected" - (NoOpSilently, 1) -> SilentNoOp "edge-1: already complete" - other -> error ("silentChoiceDomainHandler: unexpected selected edge " <> show other) - } - -retryDecisionDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent Text Text -retryDecisionDomainHandler = - DomainCommandHandler - { eventStream = retryDecisionEventStream, - classifySilent = \SilentCommandContext {state, selectedEdge} -> - case (state, Keiki.edgeIndex selectedEdge) of - (Drained, 0) -> SilentNoOp "already drained" - other -> error ("retryDecisionDomainHandler: unexpected selected edge " <> show other) - } - -coordinatorDomainHandler :: DomainCommandHandler (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent Text Text -coordinatorDomainHandler = - DomainCommandHandler - { eventStream = coordinatorEventStream, - classifySilent = \SilentCommandContext {command, selectedEdge} -> - case (command, Keiki.edgeIndex selectedEdge) of - (CoordinatorReject reason, 1) -> SilentRejected reason - (CoordinatorNoOp explanation, 2) -> SilentNoOp explanation - other -> error ("coordinatorDomainHandler: unexpected selected edge " <> show other) - } - -skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent -skipTransducer = - SymTransducer - { edgesOut = \case - Counting -> - [ Edge - { guard = matchInCtor sAddCtor, - update = UKeep, - output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)], - target = Counting, - mode = Keiki.Live - }, - Edge - { guard = matchInCtor sSkipCtor, - update = UKeep, - output = [], - target = Counting, - mode = Keiki.Live - } - ], - initial = Counting, - initialRegs = RNil, - isFinal = \_ -> False - } - -sAddCtor :: InCtor SkipCommand AddFields -sAddCtor = - Keiki.unavailableInCtor - "SAdd" - ( \case - SAdd amount -> Just (RCons Proxy amount RNil) - SSkip -> Nothing - ) - ( \case - RCons _ amount RNil -> SAdd amount - ) - -sSkipCtor :: InCtor SkipCommand '[] -sSkipCtor = - Keiki.unavailableInCtor - "SSkip" - ( \case - SAdd {} -> Nothing - SSkip -> Just RNil - ) - ( \case - RNil -> SSkip - ) - -addCtor :: InCtor CounterCommand AddFields -addCtor = - Keiki.unavailableInCtor - "Add" - ( \case - Add amount -> Just (RCons Proxy amount RNil) - ) - ( \case - RCons _ amount RNil -> Add amount - ) - -counterAddedCtor :: WireCtor CounterEvent (Int, ()) -counterAddedCtor = - Keiki.unavailableWireCtor - "CounterAdded" - ( \case - CounterAdded amount -> Just (amount, ()) - CounterAudited {} -> Nothing - ) - ( \case - (amount, ()) -> CounterAdded amount - ) - -counterAuditedCtor :: WireCtor CounterEvent (Int, ()) -counterAuditedCtor = - Keiki.unavailableWireCtor - "CounterAudited" - ( \case - CounterAudited amount -> Just (amount, ()) - CounterAdded {} -> Nothing - ) - ( \case - (amount, ()) -> CounterAudited amount - ) - -counterCodec :: Codec CounterEvent -counterCodec = - Codec - { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"], - eventType = \case - CounterAdded {} -> EventType "CounterAdded" - CounterAudited {} -> EventType "CounterAudited", - schemaVersion = 1, - encode = \case - CounterAdded amount -> object ["amount" Aeson..= amount] - CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True], - decode = parseCounterEvent, - upcasters = [] - } - -parseCounterEvent :: EventType -> Value -> Either Text CounterEvent -parseCounterEvent (EventType tag) value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "CounterEvent" $ \objectValue -> do - amount <- objectValue .: "amount" - case tag of - "CounterAdded" -> pure (CounterAdded amount) - "CounterAudited" -> pure (CounterAudited amount) - _ -> fail "unknown counter event type" - --- * Divert fixture (plan 143: replay-only transitions / black-acuity) ----- - -type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent - -type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent - -data DivertCommand - = ConfirmDivert !Bool - deriving stock (Generic, Eq, Show) - -newtype DivertEvent - = DivertConfirmed Bool - deriving stock (Generic, Eq, Show) - -data DivertState - = DivertHeld - deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) - -type DivertFields = '[ '("acuityBlack", Bool)] - -confirmDivertCtor :: InCtor DivertCommand DivertFields -confirmDivertCtor = - Keiki.unavailableInCtor - "ConfirmDivert" - ( \case - ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil) - ) - ( \case - RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack - ) - -divertConfirmedCtor :: WireCtor DivertEvent (Bool, ()) -divertConfirmedCtor = - Keiki.unavailableWireCtor - "DivertConfirmed" - ( \case - DivertConfirmed acuityBlack -> Just (acuityBlack, ()) - ) - ( \case - (acuityBlack, ()) -> DivertConfirmed acuityBlack - ) - -divertCodec :: Codec DivertEvent -divertCodec = - Codec - { eventTypes = EventType "DivertConfirmed" :| [], - eventType = \_ -> EventType "DivertConfirmed", - schemaVersion = 1, - encode = \case - DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack], - decode = parseDivertEvent, - upcasters = [] - } - -parseDivertEvent :: EventType -> Value -> Either Text DivertEvent -parseDivertEvent _ value = - case parseEither parser value of - Right event -> Right event - Left message -> Left (fromStringLiteral message) - where - parser = withObject "DivertConfirmed" $ \objectValue -> - DivertConfirmed <$> objectValue .: "acuityBlack" - --- | The old rule: confirm any reservation. -divertOldGuard :: HsPred '[] DivertCommand -divertOldGuard = matchInCtor confirmDivertCtor - --- | The tightened rule: confirm only non-black acuity. -divertNewGuard :: HsPred '[] DivertCommand -divertNewGuard = - PAnd - (matchInCtor confirmDivertCtor) - (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False) - --- | The removed region, @old ∧ ¬new@: exactly black acuity. -divertRemovedRegionGuard :: HsPred '[] DivertCommand -divertRemovedRegionGuard = - PAnd - (matchInCtor confirmDivertCtor) - (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True) - -divertConfirmEdge :: - HsPred '[] DivertCommand -> - Keiki.EdgeMode -> - Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState -divertConfirmEdge edgeGuard edgeMode = - Edge - { guard = edgeGuard, - update = UKeep, - output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)], - target = DivertHeld, - mode = edgeMode - } - -divertEventStreamDef :: - [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] -> - DivertEventStream -divertEventStreamDef heldEdges = - EventStream - { transducer = - SymTransducer - { edgesOut = \case - DivertHeld -> heldEdges, - initial = DivertHeld, - initialRegs = RNil, - isFinal = const False - }, - initialState = DivertHeld, - initialRegisters = RNil, - eventCodec = divertCodec, - resolveStreamName = Stream.streamName, - snapshotPolicy = Never, - stateCodec = Nothing - } - --- | Machine A: the original permissive rule. -permissiveDivertEventStream :: ValidatedDivertEventStream -permissiveDivertEventStream = - mkEventStreamOrThrow - "divert-permissive" - (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live]) - --- | Machine B without the twin: the tightened rule alone. -tightenedDivertEventStream :: ValidatedDivertEventStream -tightenedDivertEventStream = - mkEventStreamOrThrow - "divert-tightened" - (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live]) - --- | Machine B with the replay-only twin carrying the removed region: --- the tightened rule governs new traffic; black-acuity history keeps --- its inverting edge. -twinDivertEventStream :: ValidatedDivertEventStream -twinDivertEventStream = - mkEventStreamOrThrow - "divert-twin" - ( divertEventStreamDef - [ divertConfirmEdge divertNewGuard Keiki.Live, - divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly - ] - ) - -domainProcessManager :: - DomainProcessManager - DomainDispatchInput - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CoordinatorCommand) - '[] - CounterState - CoordinatorCommand - CounterEvent - Text - Text -domainProcessManager = - DomainProcessManager - { name = "domain-pm", - correlate = \(DomainDispatchInput correlationId _) -> correlationId, - eventStream = counterEventStream, - streamFor = \correlationId -> stream ("domain-pm:" <> correlationId), - targetHandler = coordinatorDomainHandler, - targetProjections = const [], - handle = \(DomainDispatchInput correlationId targetCommands) -> - ProcessManagerAction - { command = Add 1, - commands = - Prelude.zipWith - (\targetIndex targetCommand -> PMCommand {target = stream ("domain-pm-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand}) - [0 :: Int ..] - targetCommands, - timers = [] - } - } - -domainRouter :: - DomainRouter - DomainDispatchInput - (HsPred '[] CoordinatorCommand) - '[] - CounterState - CoordinatorCommand - CounterEvent - Text - Text - es -domainRouter = - DomainRouter - { name = "domain-router", - key = \(DomainDispatchInput correlationId _) -> correlationId, - resolve = \(DomainDispatchInput correlationId targetCommands) -> - pure - ( Prelude.zipWith - (\targetIndex targetCommand -> PMCommand {target = stream ("domain-router-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand}) - [0 :: Int ..] - targetCommands - ), - targetHandler = coordinatorDomainHandler, - targetProjections = const [] - } - -counterProcessManager :: - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -counterProcessManager = - ProcessManager - { name = "counter-pm", - correlate = \_ -> "order-1", - eventStream = counterEventStream, - streamFor = \correlationId -> stream ("pm:counter-" <> correlationId), - targetEventStream = counterEventStream, - targetProjections = const [], - handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount, - commands = - [ PMCommand - { target = stream "counter-target-order-1", - command = Add amount - } - ], - timers = [counterTimerRequest] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = [] - } - } - -unicodeCounterProcessManager :: - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -unicodeCounterProcessManager = - counterProcessManager - { name = "unicode-pm", - correlate = const "\x4E2D\x6587-42", - streamFor = const (stream "pm:counter-unicode"), - handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount, - commands = [PMCommand {target = stream "counter-target-unicode", command = Add amount}], - timers = [] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = [] - } - } - -timerOnlyProcessManager :: - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -timerOnlyProcessManager = - ProcessManager - { name = "timer-only-pm", - correlate = \_ -> "order-1", - eventStream = noOpCounterEventStream, - streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId), - targetEventStream = counterEventStream, - targetProjections = const [], - handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = - [ counterTimerRequest - & #processManagerName - .~ "timer-only-pm" - ] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = [] - } - } - --- A process manager whose OWN state stream snapshots under Every 2. --- This is the first PM fixture to exercise a state-stream snapshot: the only --- difference from counterProcessManager is that its eventStream carries a --- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so --- runProcessManagerOnce's manager-state append (which goes through --- runCommandWithSql) writes and reuses snapshots. The manager registers are --- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream; --- the target side stays '[]/counterEventStream exactly as counterProcessManager. -pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream -pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef - -pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream -pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef - -pmSnapshotProcessManager :: - ProcessManager - CounterEvent - (HsPred SnapshotCounterRegs CounterCommand) - SnapshotCounterRegs - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -pmSnapshotProcessManager = - ProcessManager - { name = "counter-snap-pm", - correlate = \_ -> "order-1", - eventStream = pmSnapshotCounterEventStream, - streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId), - targetEventStream = counterEventStream, - targetProjections = const [], - handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount, - commands = [], -- keep the test focused on the manager state stream - timers = [] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = [] - } - } - -workflowProcessManager :: - Text -> - Text -> - Text -> - ProcessManager - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent - (HsPred '[] CounterCommand) - '[] - CounterState - CounterCommand - CounterEvent -workflowProcessManager managerName managerCategory targetStreamName = - counterProcessManager - { name = managerName, - streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId), - handle = \case - CounterAdded amount -> - ProcessManagerAction - { command = Add amount, - commands = - [ PMCommand - { target = stream targetStreamName, - command = Add amount - } - ], - timers = [] - } - CounterAudited amount -> - ProcessManagerAction - { command = Add amount, - commands = [], - timers = [] - } - } - -assertWorkflowProcessManagerAppended :: - Either - Store.StoreError - ( Either - CommandError - (ProcessManagerResult CounterEventStream CounterEventStream) - ) -> - Expectation -assertWorkflowProcessManagerAppended = \case - Right (Right pmResult) -> do - pmResult ^. #managerResult `shouldSatisfy` \case - PMStateAppended {} -> True - _ -> False - pmResult ^. #commandResults `shouldSatisfy` \case - [PMCommandAppended {}] -> True - _ -> False - other -> expectationFailure ("expected workflow process-manager success, got " <> show other) - -counterTimerRequest :: TimerRequest -counterTimerRequest = - TimerRequest - { timerId = TimerId sampleUuid, - processManagerName = "counter-pm", - correlationId = "order-1", - fireAt = dueTimerTime, - payload = object ["kind" Aeson..= ("counter-timeout" :: Text)] - } - -dueTimerTime :: UTCTime -dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) +import Control.Exception (AsyncException (..), ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try) +import Control.Monad (forM, forM_) +import Data.Aeson (object, withObject, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (parseEither) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Char (isDigit) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Int (Int32) +import Data.List (isInfixOf) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Monoid (mempty) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TextIO +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime) +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.UUID (UUID, fromString, fromWords64) +import Data.UUID qualified as UUID +import Data.UUID.V5 qualified as UUID.V5 +import Data.Vector qualified as Vector +import Data.Version (showVersion) +import Data.Word (Word64) +import Effectful (Eff, IOE, runEff, (:>)) +import Effectful.Error.Static (Error, throwError) +import Effectful.Exception qualified as EffException +import ExternalReadSpec qualified +import GHC.Conc (ThreadStatus (..), threadStatus) +import GroupRebuildSpec qualified +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) +import Keiki.Core + ( Edge (..), + HsPred (..), + InCtor (..), + IndexN, + RegFile (..), + SymTransducer (..), + Update (..), + WireCtor (..), + inpCtor, + lit, + matchInCtor, + oNil, + pack, + proj, + (*:), + (.==), + ) +import Keiki.Core qualified as Keiki +import Keiki.Generics (emptyRegFile) +import Keiki.Operators qualified as K +import Keiki.Shape (CanonicalStateShape) +import Keiro +import Keiro qualified as KeiroRoot +import Keiro.Codec.Nominal + ( NominalBinding (..), + NominalFixture (..), + NominalFixtureCases (..), + nominalDomainRoundTrip, + nominalRepresentationRoundTrip, + ) +import Keiro.Codec.Structural + ( StructuralBinding (..), + bindingDomainRoundTrip, + bindingShapeRoundTrip, + decodeViaBinding, + encodeViaBinding, + ) +import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema) +import Keiro.DeadLetter + ( DispatchDeadLetter (..), + DispatcherKind (..), + listDispatchDeadLetters, + recordDispatchDeadLetter, + ) +import Keiro.DeadLetter.Replay + ( ReplayOutcome (..), + ReplayResult (..), + listSubscriptionDeadLetters, + replaySubscriptionDeadLetters, + ) +import Keiro.DeterministicId (deterministicIdProbes, identitySeedBytes, legacySeedBytes) +import Keiro.EventStream (Terminality (..)) +import Keiro.EventStream.Validate + ( EventStreamWarning (..), + ValidatedEventStream, + mkEventStream, + mkEventStreamOrThrow, + mkEventStreamUnchecked, + mkEventStreamWith, + validateEventStream, + ) +import Keiro.Inbox + ( DelegatedOutcome (..), + InboxDedupePolicy (..), + InboxError (..), + InboxPersistence (..), + InboxResult (..), + InboxStatus (..), + KafkaDeliveryRef (..), + garbageCollectCompleted, + listInbox, + lookupInbox, + markFailedTx, + mkDelegatedRetryContext, + runInboxDelegated, + runInboxDelegatedBatch, + runInboxDelegatedWithRetries, + runInboxTransaction, + runInboxTransactionBatch, + runInboxTransactionWith, + runInboxTransactionWithRetries, + runInboxTransactionWithRetriesWith, + sampleInboxBacklog, + ) +import Keiro.Inbox.Delegated + ( DelegatedCommandError (..), + delegatedCommand, + delegatedEventId, + delegatedFromPMCommand, + ) +import Keiro.Inbox.Kafka qualified as InboxKafka +import Keiro.Integration.Event + ( IntegrationContentType (..), + IntegrationEvent (..), + SchemaReference (..), + TraceContext (..), + decodeJsonIntegrationEvent, + encodeJsonIntegrationEvent, + headerContentType, + headerMessageId, + headerSchemaSubject, + headerSchemaVersion, + headerSourceEventId, + headerSourceGlobalPosition, + headerTraceParent, + integrationHeaders, + integrationPayload, + parseContentType, + ) +import Keiro.Integration.Event qualified as IntegrationEvent +import Keiro.Outbox + ( BackoffSchedule (..), + ExponentialBackoffOptions (..), + IntegrationEventDraft (..), + IntegrationProducer (..), + IntegrationProducerConfigError (..), + OrderingPolicy (..), + OutboxId (..), + OutboxPublishConfigError (..), + OutboxRow (..), + OutboxStatus (..), + PublishOutcome (..), + PublishRejectionError (..), + claimOutboxBatch, + defaultMaintenanceOptions, + defaultPublishOptions, + draftToEvent, + enqueueIntegrationEventTx, + freshIntegrationEvent, + freshOutboxId, + garbageCollectSent, + lookupOutbox, + markOutboxSent, + mkIntegrationProducer, + mkOutboxPublishOptions, + mkPublishRejection, + outboxMaintenancePass, + publishClaimedOutbox, + publishRejectionCode, + publishRejectionDetail, + sampleOutboxBacklog, + ) +import Keiro.Outbox qualified as ProducerOutbox +import Keiro.Outbox.Kafka qualified as OutboxKafka +import Keiro.Outbox.Schema (markOutboxFailedTx, markOutboxRejectedTx) +import Keiro.Prelude +import Keiro.ProcessManager +import Keiro.ProcessManager.Reaction qualified as Reaction +import Keiro.Projection +import Keiro.ReadModel +import Keiro.ReadModel.Rebuild qualified as Rebuild +import Keiro.ReplayAudit qualified as ReplayAudit +import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan) +import Keiro.Stream qualified as Stream +import Keiro.Subscription.Shard + ( ShardCountMismatch (..), + ShardLease (..), + WorkerId (..), + ensureShards, + fairShareTarget, + ) +import Keiro.Subscription.Shard.Schema + ( claimShardsTx, + ensureShardRows, + listShardOwnership, + releaseShardsTx, + renewLeaseTx, + ) +import Keiro.Subscription.Shard.Worker + ( ShardAck (..), + ShardWorkerError (..), + ShardedWorkerConfigError (..), + ShardedWorkerOptions (..), + acquireOutcome, + defaultShardedWorkerOptions, + mkShardedWorkerOptions, + reconcileShardsOnce, + runShardedSubscriptionGroup, + runShardedSubscriptionGroupAck, + ) +import Keiro.Telemetry qualified as Telemetry +import Keiro.Test.Postgres + ( StoreRunner (..), + withFreshDatabase, + withFreshResourceStore, + withFreshResourceStorePrepared, + withFreshResourceStoreWith, + withFreshStore, + withFreshStoreWith, + withFreshStores2, + withMigratedSuite, + ) +import Keiro.Timer +import Keiro.Timer qualified as Timer +import Keiro.Wake + ( WakeReason (..), + WakeSignal (..), + neverWake, + wakeSignalFromStore, + ) +import Keiro.Workflow + ( LeaseHeartbeat (..), + PatchId (..), + StepName (..), + Workflow, + WorkflowError (..), + WorkflowId (..), + WorkflowIdentityError (..), + WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed), + WorkflowLeaseLost (..), + WorkflowName (..), + WorkflowOutcome (..), + appendJournalEntry, + appendJournalEntryReturningId, + awaitStep, + awakeableAllocStepPrefix, + awakeableStepPrefix, + cancelledStepName, + completedStepName, + continueAsNew, + continueSeedStepName, + continuedAsNewStepName, + currentGeneration, + defaultWorkflowRunOptions, + deterministicJournalId, + failedStepName, + findUnfinishedWorkflowIds, + loadStepIndex, + mkWorkflowId, + mkWorkflowName, + patch, + patchSetStepName, + patchStepName, + restoreSeed, + runWorkflow, + runWorkflowWith, + step, + stepExists, + workflowGenerationStreamName, + workflowJournalCodec, + ) +import Keiro.Workflow.Awakeable + ( AwakeableId (..), + WorkflowAwakeableCancelled (..), + awakeableIdText, + awakeableIdToUuid, + awakeableNamed, + cancelAwakeable, + signalAwakeable, + signalAwakeableFrom, + ) +import Keiro.Workflow.Awakeable.Compatibility + ( generation0AwakeableId, + preUtf8Generation0AwakeableId, + ) +import Keiro.Workflow.Awakeable.Schema qualified as Awk +import Keiro.Workflow.Child + ( ChildHandle (..), + WorkflowChildCancelled (..), + WorkflowChildFailed (..), + awaitChild, + cancelChild, + childCompletionHook, + childResultStepName, + childSpawnStepName, + runChildWorkflow, + spawnChild, + ) +import Keiro.Workflow.Child.Schema qualified as Child +import Keiro.Workflow.Gc qualified as WorkflowGc +import Keiro.Workflow.Instance qualified as Instance +import Keiro.Workflow.Resume + ( ResumeLogEvent (..), + ResumeSummary (..), + WorkflowDef (..), + defaultWorkflowResumeOptions, + emptyResumeSummary, + resumeWorkflowsOnce, + runPollLoopWith, + runWorkflowResumeWorkerPush, + runWorkflowResumeWorkerWith, + ) +import Keiro.Workflow.Sleep + ( drainWorkflowSleepTimers, + matchSleepTimerGeneration, + parseSleepPayload, + runWorkflowTimerWorker, + sleepNamed, + sleepStepName, + sleepTimerId, + sleepTimerPayload, + workflowSleepFireAction, + ) +import Keiro.Workflow.Snapshot + ( loadWorkflowSnapshot, + workflowStateCodec, + ) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (Store) +import Kiroku.Store.SQL qualified as KirokuSQL +import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream) +import Kiroku.Store.Subscription.Types + ( SubscriptionName (..), + SubscriptionTarget (..), + ) +import Kiroku.Store.Subscription.Types qualified as KirokuSub +import Kiroku.Store.Types + ( CategoryName (..), + EventData (..), + EventId (..), + EventType (..), + ExpectedVersion (..), + GlobalPosition (..), + RecordedEvent (..), + StreamId (..), + StreamName (..), + StreamVersion (..), + ) +import Numeric.Natural (Natural) +import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute) +import OpenTelemetry.Attributes.Key (AttributeKey, unkey) +import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Exporter.Metric + ( GaugeDataPoint (..), + HistogramDataPoint (..), + MetricExport (..), + NumberValue (..), + ResourceMetricsExport (..), + ScopeMetricsExport (..), + SumDataPoint (..), + ) +import OpenTelemetry.MeterProvider + ( SdkMeterProviderOptions (..), + createMeterProvider, + defaultSdkMeterProviderOptions, + ) +import OpenTelemetry.Metric.Core + ( forceFlushMeterProvider, + getMeter, + ) +import OpenTelemetry.Resource (emptyMaterializedResources) +import OpenTelemetry.Trace + ( SpanStatus (..), + createTracerProvider, + emptyTracerProviderOptions, + makeTracer, + shutdownTracerProvider, + tracerOptions, + ) +import OpenTelemetry.Trace.Core + ( ImmutableSpan (..), + Span, + SpanContext (..), + SpanHot (..), + SpanKind, + getSpanContext, + ) +import Paths_keiro qualified as Package +import PreCanonicalRecoverySpec qualified +import PreimageSpec qualified +import ProjectionReplaySpec qualified +import ReactionExample qualified +import ReadModelSpec qualified +import Shibuya.Adapter (Adapter (..)) +import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..), deadLetterCodeText, deadLetterReasonCode, deadLetterReasonDetail, renderDeadLetterReason) +import Shibuya.Core.AckHandle (AckHandle (..)) +import Shibuya.Core.Ingested (Ingested (..)) +import Shibuya.Core.Types (Envelope (..)) +import Streamly.Data.Stream qualified as Streamly +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import System.Timeout (timeout) +import Test.Hspec +import VersionedRebuildSpec qualified +import VersionedTargetPostgresSpec qualified +import "hasql-transaction" Hasql.Transaction qualified as Tx + +main :: IO () +main = withMigratedSuite $ \fixture -> hspec $ do + CatalogSpec.spec + PreimageSpec.spec + CatalogEvolutionSpec.spec fixture + CatalogOperationsSpec.spec fixture + GroupRebuildSpec.spec fixture + ExternalReadSpec.spec fixture + VersionedTargetPostgresSpec.spec fixture + VersionedRebuildSpec.spec fixture + PreCanonicalRecoverySpec.spec fixture + ProjectionReplaySpec.spec fixture + ReadModelSpec.spec + + describe "catalog-fenced inline projections" $ around (withFreshResourceStore fixture) $ do + it "rolls back the event append and target write while its group rebuilds" $ \(_storeHandle, StoreRunner runStore) -> do + validated <- + case validateProjectionCatalog catalogInlineProjectionCatalog of + Failure diagnostics -> + expectationFailure ("catalog fixture failed validation: " <> show diagnostics) + >> error "unreachable" + Success value -> pure value + Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) + Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated + + let targetStream = stream "counter-catalog-fence" :: Stream CounterEventStream + first <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 4) + validated + catalogInlineProjectionSet + first `shouldSatisfy` \case + Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 + _ -> False + Right 1 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + + Right (Right _) <- + runStore $ + Rebuild.beginGroupRebuild + validated + catalogInlineGroupId + Rebuild.RebuildRequest + { rebuildRunId = catalogInlineRunId, + requestedBy = "keiro-test", + requestReason = "inline fence proof", + replayFrom = GlobalPosition 0 + } + Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + + second <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 5) + validated + catalogInlineProjectionSet + second + `shouldBe` Right (Right (ProjectionCommandFenced catalogInlineGroupId catalogInlineRunId)) + Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + Right recorded <- + runStore $ + Store.readStreamForward (StreamName "counter-catalog-fence") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + let foreignSource = catalogIdentity mkSourceId "catalog-inline-foreign-source" + foreignSet = catalogInlineProjectionSet & #projectionSource .~ foreignSource + foreignStream = stream "counter-catalog-mismatch" :: Stream CounterEventStream + mismatch <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + foreignStream + (Add 6) + validated + foreignSet + mismatch `shouldBe` Right (Right (ProjectionCommandCatalogMismatch foreignSource)) + Right absent <- + runStore $ + Store.readStreamForward (StreamName "counter-catalog-mismatch") (StreamVersion 0) 10 + Vector.null absent `shouldBe` True + + it "waits for an in-flight writer before preparing and clearing its group" $ \(_storeHandle, StoreRunner runStore) -> do + validated <- + case validateProjectionCatalog catalogInlineProjectionCatalog of + Failure diagnostics -> + expectationFailure ("catalog fixture failed validation: " <> show diagnostics) + >> error "unreachable" + Success value -> pure value + Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) + Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated + + writerDone <- newEmptyMVar + let targetStream = stream "counter-catalog-lock-order" :: Stream CounterEventStream + _ <- + forkIO $ + runStore + ( runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 9) + validated + catalogSlowInlineProjectionSet + ) + >>= putMVar writerDone + threadDelay 200_000 + startedAt <- getCurrentTime + Right (Right _) <- + runStore $ + Rebuild.beginGroupRebuild + validated + catalogInlineGroupId + Rebuild.RebuildRequest + { rebuildRunId = catalogInlineRunId, + requestedBy = "keiro-test", + requestReason = "in-flight inline lock proof", + replayFrom = GlobalPosition 0 + } + finishedAt <- getCurrentTime + + writer <- takeMVar writerDone + writer `shouldSatisfy` \case + Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 + _ -> False + diffUTCTime finishedAt startedAt `shouldSatisfy` (> 0.5) + Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + pure () + + it "dispatches inline writes through the persisted serving revision before appending" $ \(_storeHandle, StoreRunner runStore) -> do + validated <- expectValidatedCatalog catalogInlineProjectionCatalog + v1Only <- expectValidatedCatalog catalogInlineV1Catalog + Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) + Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated + Right () <- runStore $ Store.runTransaction (Tx.sql seedCatalogInlineVersionedV1Sql) + + let targetStream = stream "counter-versioned-inline" :: Stream CounterEventStream + first <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 4) + validated + catalogInlineProjectionSet + first `shouldSatisfy` \case + Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 + _ -> False + Right [101] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) + + Right () <- runStore $ Store.runTransaction (Tx.sql promoteCatalogInlineV2Sql) + second <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 5) + validated + catalogInlineProjectionSet + second `shouldSatisfy` \case + Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1 + _ -> False + Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) + + missing <- + runStore $ + runCommandWithCatalogProjections + defaultRunCommandOptions + counterEventStream + targetStream + (Add 6) + v1Only + catalogInlineProjectionSet + missing + `shouldBe` Right + ( Right + ( ProjectionCommandServingRevisionUnavailable + catalogInlineGroupId + catalogInlineRevisionV2Id + ) + ) + Right recorded <- + runStore $ + Store.readStreamForward (StreamName "counter-versioned-inline") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 2 + Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt) + pure () + + describe "Keiro" $ do + it "exposes the package metadata version" $ + KeiroRoot.version `shouldBe` Text.pack (showVersion Package.version) + + it "keeps package metadata as the only version authority" $ do + source <- TextIO.readFile "src/Keiro.hs" + source `shouldSatisfy` Text.isInfixOf "showVersion Package.version" + let isNumericVersionAssignment sourceLine = + "version =" `Text.isInfixOf` sourceLine + && Text.count "." sourceLine >= 3 + && Text.any isDigit sourceLine + Text.lines source `shouldSatisfy` all (not . isNumericVersionAssignment) + + describe "Keiro.Telemetry metrics" $ do + it "records instrument names and values through an SDK meter" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + let h = Just metrics + -- A counter (monotonic sum), a gauge (last value wins), a histogram. + Telemetry.recordOutboxPublished h 3 + Telemetry.recordOutboxPublished h 2 + Telemetry.recordOutboxBacklog h 7 + Telemetry.recordInboxDuplicates h 1 + Telemetry.recordTimerFireLag h 12.5 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- The counter accumulated 3 + 2 = 5. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5) + -- The gauge holds its last recorded value. + lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7) + -- The duplicate counter holds 1. + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + -- The histogram saw one observation summing to 12.5. + let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] + lag `shouldBe` [(1, 12.5)] + -- Instruments we never recorded export no points. + lookup "keiro.timer.stuck" scalars `shouldBe` Nothing + + it "records nothing through a Nothing handle" $ do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + -- A Nothing handle is the no-op path: helpers must short-circuit. + let h = Nothing + Telemetry.recordOutboxPublished h 99 + Telemetry.recordOutboxBacklog h 99 + Telemetry.recordTimerFireLag h 99.0 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Kiroku retry exhaustion observability" $ do + it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + forwarded <- newIORef (0 :: Int) + let observe _ = modifyIORef' forwarded (+ 1) + installBridge settings = + settings + & #eventHandler + .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe) + withFreshStoreWith fixture installBridge $ \store -> do + total <- seedOrders store 1 2 + total `shouldBe` 2 + let subName = SubscriptionName "orders-retry-exhaustion" + subConfig = + ( KirokuSub.defaultSubscriptionConfig + subName + (Category (CategoryName "orders")) + (\_ -> pure KirokuSub.Continue) + ) + { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2 + } + pull label source = do + result <- timeout 5_000_000 (Streamly.uncons source) + case result of + Just (Just itemAndRest) -> pure itemAndRest + Just Nothing -> fail (label <> ": subscription ended early") + Nothing -> fail (label <> ": timed out waiting for delivery") + number item = + parseEither + (withObject "OrderPlaced" (.: "n")) + (ackEvent item ^. #payload) + (stream0, cancelStream) <- subscriptionAckStream store subConfig 4 + ( do + (first, stream1) <- pull "initial poison delivery" stream0 + ackAttempt first `shouldBe` 0 + number first `shouldBe` Right (0 :: Int) + atomically $ + putTMVar + (ackReply first) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (retry, stream2) <- pull "poison redelivery" stream1 + ackAttempt retry `shouldBe` 1 + ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId + atomically $ + putTMVar + (ackReply retry) + (KirokuSub.Retry (KirokuSub.RetryDelay 0)) + + (next, stream3) <- pull "event after exhausted poison" stream2 + ackAttempt next `shouldBe` 0 + number next `shouldBe` Right (1 :: Int) + ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId + atomically (putTMVar (ackReply next) KirokuSub.Stop) + ended <- timeout 5_000_000 (Streamly.uncons stream3) + case ended of + Just Nothing -> pure () + Just (Just _) -> expectationFailure "subscription delivered after Stop" + Nothing -> expectationFailure "subscription did not stop after the final acknowledgement" + ) + `finally` cancelStream + + Right rows <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.statement + ("orders-retry-exhaustion", 0) + KirokuSQL.readDeadLettersStmt + case Vector.toList rows of + [row] -> do + row ^. #deadLetterReason + `shouldBe` object + [ "kind" Aeson..= ("max_attempts_exceeded" :: Text), + "attempts" Aeson..= (2 :: Int) + ] + row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)" + row ^. #deadLetterAttemptCount `shouldBe` 2 + other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other) + + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + readIORef forwarded >>= (`shouldSatisfy` (> 1)) + + describe "Keiro.Stream" $ do + it "wraps and unwraps kiroku stream names" $ do + let orderStream = stream "order-123" :: Stream OrderStream + Stream.streamName orderStream `shouldBe` StreamName "order-123" + Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream) + `shouldBe` StreamName "order-123-archived" + + it "validates categories, rejecting the dash boundary and reserved names" $ do + fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "incident" + -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted + fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "hospitalSurge" + fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Right "wf:fulfillment" + (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left Stream.CategoryEmpty + (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge") + (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryReserved "$all") + (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers") + (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ())) + `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners") + + it "builds entity streams that round-trip through kiroku's category rule" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1" + Stream.categoryName cat `shouldBe` CategoryName "orders" + -- The category keiro reports equals kiroku's own parse of the produced + -- name, even when the id segment itself contains a dash. + Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c")) + `shouldBe` Stream.categoryName cat + + it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1" + Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1" + + it "rejects blank entity stream id segments" $ do + let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream + evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall + evaluate (Stream.streamName (Stream.entityStream cat " ")) `shouldThrow` anyErrorCall + + describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do + it "records a dispatch dead letter idempotently" $ \storeHandle -> do + let deadLetter = + DispatchDeadLetter + { dispatcherKind = DispatcherProcessManager, + dispatcherName = "orders-pm", + correlationId = "order-42", + sourceEventId = EventId sampleUuid, + sourceGlobalPosition = GlobalPosition 17, + emitIndex = 0, + targetStreamName = StreamName "orders-42", + errorClass = "command_rejected", + errorDetail = Text.replicate 1100 "x", + attemptCount = 2 + } + Right rows <- + Store.runStoreIO storeHandle $ do + recordDispatchDeadLetter deadLetter + recordDispatchDeadLetter deadLetter + listDispatchDeadLetters "orders-pm" + case rows of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #dispatcherName `shouldBe` "orders-pm" + row ^. #correlationId `shouldBe` "order-42" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17 + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "orders-42" + row ^. #errorClass `shouldBe` "command_rejected" + Text.length (row ^. #errorDetail) `shouldBe` 1024 + row ^. #attemptCount `shouldBe` 2 + other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other) + + describe "Keiro.Codec" $ do + it "encodes current events with type tags and schema-version metadata" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + encoded ^. #eventType `shouldBe` EventType "OrderPlaced" + encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)] + extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2 + + it "round-trips current events" $ do + encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5)) + decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5) + + it "decodes by the stored tag, not by payload shape (H1)" $ do + let recorded = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "CounterAudited", + payload = object ["amount" Aeson..= (5 :: Int)], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5) + + it "runs upcasters in source-version order" $ + decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Right (OrderPlaced "order-123" 5) + + it "rejects gaps in upcaster chains" $ + decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]) + `shouldBe` Left (GapInUpcasterChain 2 3) + + it "validates codec construction invariants" $ do + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0) + fmap (const ()) (mkCodec (orderCodec {eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]})) + `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"]) + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecDuplicateUpcasterSources [1]) + fmap (const ()) (mkCodec (orderCodec {schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]})) + `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3) + case mkCodec orderCodec of + Right _ -> pure () + Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err) + + it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do + let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)] + earlyEndCodec = + orderCodec + { schemaVersion = 4, + upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)] + } + decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload + `shouldBe` Left (VersionAhead 3 2) + decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload + `shouldBe` Left (IncompleteUpcasterChain 3 4) + + let malformedStamp = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "OrderPlaced", + payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)], + metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)]), + causationId = Nothing, + correlationId = Nothing + } + extractSchemaVersion malformedStamp + `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2")) + fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5)) + `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x")) + + it "rejects recorded events with unknown type tags" $ do + let encoded = + recordedFrom + EventData + { eventId = Nothing, + eventType = EventType "OrderCancelled", + payload = object ["orderId" Aeson..= ("order-123" :: Text)], + metadata = Just (metadataForOrDie 2 Nothing), + causationId = Nothing, + correlationId = Nothing + } + decodeRecorded orderCodec encoded + `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"]) + + describe "Keiro.Codec.Structural" $ do + let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int) + pairBinding = + StructuralBinding + { bindingToShape = \(amount, enabled) -> (enabled, amount), + bindingFromShape = \(enabled, amount) -> (amount, enabled) + } + encodePairShape (enabled, amount) = + object ["enabled" Aeson..= enabled, "amount" Aeson..= amount] + decodePairShape value = + case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of + Left err -> Left (Text.pack err) + Right shape -> Right shape + + it "checks both total binding laws" $ do + bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True + bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True + + it "delegates encoding to the generated shape codec" $ + encodeViaBinding pairBinding encodePairShape (7, True) + `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)] + + it "propagates only shape decode failures before total construction" $ do + let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)] + decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False) + decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null + `shouldBe` Left "shape-error" + + describe "Keiro.Codec.Nominal" $ do + let swappedBinding :: NominalBinding (Int, Bool) (Bool, Int) + swappedBinding = + NominalBinding + { nominalToRepresentation = \(amount, enabled) -> (enabled, amount), + nominalFromRepresentation = \(enabled, amount) -> (amount, enabled) + } + fixtures = + NominalFixtureCases + ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) + :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] + ) + + it "checks both total nominal binding laws" $ do + nominalDomainRoundTrip swappedBinding (7, True) `shouldBe` True + nominalRepresentationRoundTrip swappedBinding (False, 9) `shouldBe` True + + it "retains labelled expected-wire fixtures" $ + nominalFixtureCases fixtures + `shouldBe` ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True) + :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)] + ) + + describe "Keiro.EventStream" $ do + it "constructs an author-facing EventStream contract" $ do + let contract = + EventStream + { transducer = emptyTransducer, + initialState = Idle, + initialRegisters = RNil, + eventCodec = orderCodec, + resolveStreamName = \s -> Stream.streamName s, + snapshotPolicy = Never, + stateCodec = Nothing + } + typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent) + contract ^. #initialState `shouldBe` Idle + (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123" + + it "evaluates snapshot policies with explicit terminality" $ do + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False + shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True + shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True + shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1) + `shouldBe` True + shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1) + `shouldBe` False + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4) + `shouldBe` True + shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5) + `shouldBe` False + + it "rejects snapshot policies without a state codec" $ do + let contract :: CounterEventStream + contract = counterEventStreamDef {snapshotPolicy = Every 10, stateCodec = Nothing} + fmap (const ()) (mkEventStream "snapshotless" contract) + `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"] + + describe "EventStream replay-safety (validateEventStream)" $ do + it "every production-intent stream validates clean" $ + concat + [ validateEventStream "counter" counterEventStreamDef, + validateEventStream "counter-no-op" noOpCounterEventStreamDef, + validateEventStream "counter-multi" multiCounterEventStreamDef, + validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef, + validateEventStream "snapshot-counter" snapshotCounterEventStreamDef, + validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef, + validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef, + validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef, + validateEventStream "rejecting-counter" rejectingEventStreamDef + ] + `shouldBe` [] + + describe "mkEventStream" $ do + it "rejects duplicate upcaster sources at the stream boundary" $ do + let duplicateCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(1, const Right), (1, const Right)] + } + duplicateStream = counterEventStreamDef {eventCodec = duplicateCodec} + case mkEventStream "duplicate-codec" duplicateStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec") + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1") + Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources" + + it "rejects a missing upcaster rung at the stream boundary" $ do + let incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} + case mkEventStream "incomplete-codec" incompleteStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec") + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1") + Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain" + + it "includes the stream label when throwing for an invalid codec" $ do + let incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec} + result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream)) + case result of + Left err -> do + displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec" + displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1" + Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain" + + it "keeps invalid codecs available through the unchecked escape hatch" $ do + let duplicateCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(1, const Right), (1, const Right)] + } + incompleteCodec = + counterCodec + { schemaVersion = 3, + upcasters = [(2, const Right)] + } + _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = duplicateCodec}) + _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = incompleteCodec}) + pure () + + it "rejects a hidden-input stream by label" $ do + let warns = validateEventStream "broken" brokenHiddenInputEventStream + warns `shouldNotBe` [] + map eswStreamLabel warns `shouldSatisfy` all (== "broken") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input") + case mkEventStream "broken" brokenHiddenInputEventStream of + Left ws -> do + map eswStreamLabel ws `shouldSatisfy` all (== "broken") + map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input") + Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream" + + it "rejects a head-unrecoverable multi-event stream" $ + expectValidationWarning + "head-unrecoverable" + "head-unrecoverable" + headUnrecoverableEventStreamDef + + it "rejects replay inversion ambiguity" $ + expectValidationWarning + "inversion-ambiguity" + "inversion-ambiguity" + inversionAmbiguousEventStreamDef + + it "rejects an unguarded command-field read" $ + expectValidationWarning + "unguarded-input-read" + "unguarded-input-read" + unguardedInputReadEventStreamDef + + it "rejects a silent edge that writes registers" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "state-changing-epsilon" + "state-changing-epsilon" + stateChangingEpsilonEventStreamDef + + it "rejects a silent edge that changes vertex" $ do + Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer + `shouldSatisfy` any isStateChangingEpsilon + expectValidationWarning + "silent-move" + "state-changing-epsilon" + silentMoveEventStreamDef + + it "keeps replay-contract checks enabled when caller options weaken them" $ do + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkStateChangingEpsilon = False} + "silent-move-weakened" + silentMoveEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") + Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check" + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkHeadRecoverability = False} + "head-unrecoverable-weakened" + headUnrecoverableEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable") + Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check" + + it "provides a loudly named unchecked escape hatch" $ do + _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef) + pure () + + it "accepts every production-intent stream" $ do + let expectAccepted label eventStream = + case mkEventStream label eventStream of + Right _ -> pure () + Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws) + expectAccepted "counter" counterEventStreamDef + expectAccepted "counter-no-op" noOpCounterEventStreamDef + expectAccepted "counter-multi" multiCounterEventStreamDef + expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef + expectAccepted "snapshot-counter" snapshotCounterEventStreamDef + expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + expectAccepted "rejecting-counter" rejectingEventStreamDef + + it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do + case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of + Left warns -> do + map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers") + map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten") + Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register" + + it "accepts the same snapshot stream when every initial register is initialized" $ do + case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of + Right _ -> pure () + Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns) + + it "rejects a bare EventStream at runCommand (compile-time)" $ do + (exitCode, _stdout, stderr) <- + readProcessWithExitCode + "cabal" + [ "exec", + "ghc", + "--", + "-fno-code", + "-package", + "keiro-" <> showVersion Package.version, + "test/ReplaySafetyTypeProbe.hs" + ] + "" + exitCode `shouldSatisfy` (/= ExitSuccess) + stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`) + + describe "Keiro.Command" $ around (withFreshStore fixture) $ do + describe "typed domain command outcomes" $ do + it "returns the exact ordered accepted batch and compatibility result" $ \storeHandle -> do + let target = stream "domain-command-accepted" :: Stream CounterEventStream + commandResult <- + Store.runStoreIO storeHandle $ + runDomainCommand defaultRunCommandOptions multiCounterDomainHandler target (Add 4) + case commandResult of + Right (Right outcome@DomainCommandOutcome {decision = DomainAccepted events, result}) -> do + events `shouldBe` (CounterAdded 4 :| [CounterAudited 4]) + result ^. #streamVersion `shouldBe` StreamVersion 2 + result ^. #eventsAppended `shouldBe` 2 + forgetDomainDecision outcome `shouldBe` result + other -> expectationFailure ("expected typed accepted command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "domain-command-accepted") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 4, CounterAudited 4] + + it "attributes sibling silent edges and returns typed rejection and no-op" $ \storeHandle -> do + let rejectionTarget = stream "domain-command-rejected" :: Stream SilentChoiceEventStream + noOpTarget = stream "domain-command-no-op" :: Stream SilentChoiceEventStream + rejectionResult <- + Store.runStoreIO storeHandle $ + runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler rejectionTarget RejectSilently + case rejectionResult of + Right (Right outcome@DomainCommandOutcome {decision = DomainRejected reason, result}) -> do + reason `shouldBe` "edge-0: rejected" + result ^. #eventsAppended `shouldBe` 0 + result ^. #streamVersion `shouldBe` StreamVersion 0 + result ^. #globalPosition `shouldBe` Nothing + forgetDomainDecision outcome `shouldBe` result + other -> expectationFailure ("expected typed domain rejection, got " <> show other) + noOpResult <- + Store.runStoreIO storeHandle $ + runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler noOpTarget NoOpSilently + case noOpResult of + Right (Right outcome@DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do + explanation `shouldBe` "edge-1: already complete" + result ^. #eventsAppended `shouldBe` 0 + result ^. #streamVersion `shouldBe` StreamVersion 0 + result ^. #globalPosition `shouldBe` Nothing + forgetDomainDecision outcome `shouldBe` result + other -> expectationFailure ("expected typed domain no-op, got " <> show other) + Right rejectedEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "domain-command-rejected") (StreamVersion 0) 10 + Right noOpEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "domain-command-no-op") (StreamVersion 0) 10 + rejectedEvents `shouldBe` Vector.empty + noOpEvents `shouldBe` Vector.empty + + it "keeps unmatched and ambiguous selection failures as CommandError" $ \storeHandle -> do + let unmatchedTarget = stream "domain-command-unmatched" :: Stream SilentChoiceEventStream + ambiguousTarget = stream "domain-command-ambiguous" :: Stream CounterEventStream + unmatched <- + Store.runStoreIO storeHandle $ + runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler unmatchedTarget UnmatchedSilently + ambiguous <- + Store.runStoreIO storeHandle $ + runDomainCommand defaultRunCommandOptions ambiguousCounterDomainHandler ambiguousTarget (Add 1) + unmatched `shouldBe` Right (Left CommandRejected) + ambiguous `shouldBe` Right (Left (CommandAmbiguous [0, 1])) + + it "retains validated rejection of state-changing silent edges" $ \_ -> do + case mkEventStream "domain-state-changing-epsilon" stateChangingEpsilonEventStreamDef of + Left warnings -> + map eswReason warnings + `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon") + Right _ -> expectationFailure "expected validation to reject a state-changing silent edge" + + it "runs SQL once with the exact accepted event pairs" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "domain-command-sql-accepted" :: Stream CounterEventStream + outcome <- + runner $ + runDomainCommandWithSqlEvents + defaultRunCommandOptions + multiCounterDomainHandler + target + (Add 6) + (\pairs _appendResult -> pure (Prelude.fst <$> pairs)) + case outcome of + Right + ( Right + ( DomainCommandOutcome {decision = DomainAccepted events, result}, + Just callbackEvents + ) + ) -> do + events `shouldBe` (CounterAdded 6 :| [CounterAudited 6]) + callbackEvents `shouldBe` NonEmpty.toList events + result ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected accepted SQL domain command, got " <> show other) + + it "skips SQL callbacks and inline projections for rejection and no-op" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let rejectionTarget = stream "domain-command-sql-rejected" :: Stream SilentChoiceEventStream + noOpTarget = stream "domain-command-projection-no-op" :: Stream SilentChoiceEventStream + callback _ _ = error "silent domain decision invoked SQL callback" :: Tx.Transaction Text + projection = + InlineProjection + { name = "silent-domain-bomb", + apply = \_ _ -> error "silent domain decision invoked projection" + } + rejected <- + runner $ + runDomainCommandWithSqlEvents + defaultRunCommandOptions + silentChoiceDomainHandler + rejectionTarget + RejectSilently + callback + case rejected of + Right (Right (DomainCommandOutcome {decision = DomainRejected reason}, Nothing)) -> + reason `shouldBe` "edge-0: rejected" + other -> expectationFailure ("expected silent SQL rejection, got " <> show other) + noOp <- + runner $ + runDomainCommandWithProjections + defaultRunCommandOptions + silentChoiceDomainHandler + noOpTarget + NoOpSilently + [projection] + case noOp of + Right (Right DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do + explanation `shouldBe` "edge-1: already complete" + result ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected silent projection no-op, got " <> show other) + + it "applies inline projections atomically for accepted domain events" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "domain-command-projection-accepted" :: Stream CounterEventStream + outcome <- + runner $ + runDomainCommandWithProjections + defaultRunCommandOptions + multiCounterDomainHandler + target + (Add 7) + [counterInlineProjection] + case outcome of + Right (Right DomainCommandOutcome {decision = DomainAccepted events}) -> + events `shouldBe` (CounterAdded 7 :| [CounterAudited 7]) + other -> expectationFailure ("expected accepted projected domain command, got " <> show other) + projected <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "inline" + projected `shouldBe` Right (Right 7) + + it "preserves catalog outcomes while skipping catalog SQL for silent decisions" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + validated <- + case validateProjectionCatalog catalogInlineProjectionCatalog of + Failure diagnostics -> + expectationFailure ("catalog fixture failed validation: " <> show diagnostics) + >> error "unreachable" + Success value -> pure value + Right () <- runner $ Store.runTransaction (Tx.sql catalogInlineFixtureSql) + Right (Right _) <- runner $ Rebuild.registerProjectionCatalog validated + let target = stream "domain-command-catalog-rejected" :: Stream SilentChoiceEventStream + outcome <- + runner $ + runDomainCommandWithCatalogProjections + defaultRunCommandOptions + silentChoiceDomainHandler + target + RejectSilently + validated + catalogInlineProjectionSet + case outcome of + Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainRejected reason})) -> + reason `shouldBe` "edge-0: rejected" + other -> expectationFailure ("expected applied silent catalog decision, got " <> show other) + Right 0 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + let acceptedTarget = stream "domain-command-catalog-accepted" :: Stream CounterEventStream + accepted <- + runner $ + runDomainCommandWithCatalogProjections + defaultRunCommandOptions + multiCounterDomainHandler + acceptedTarget + (Add 5) + validated + catalogInlineProjectionSet + case accepted of + Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainAccepted events})) -> + events `shouldBe` (CounterAdded 5 :| [CounterAudited 5]) + other -> expectationFailure ("expected applied accepted catalog decision, got " <> show other) + Right 2 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt) + Right (Right _) <- + runner $ + Rebuild.beginGroupRebuild + validated + catalogInlineGroupId + Rebuild.RebuildRequest + { rebuildRunId = catalogInlineRunId, + requestedBy = "keiro-test", + requestReason = "typed domain catalog fence proof", + replayFrom = GlobalPosition 0 + } + let fencedTarget = stream "domain-command-catalog-fenced" :: Stream CounterEventStream + fenced <- + runner $ + runDomainCommandWithCatalogProjections + defaultRunCommandOptions + multiCounterDomainHandler + fencedTarget + (Add 8) + validated + catalogInlineProjectionSet + fenced + `shouldBe` Right (Right (DomainProjectionCommandFenced catalogInlineGroupId catalogInlineRunId)) + Right recorded <- + runner $ + Store.readStreamForward (StreamName "domain-command-catalog-fenced") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + pure () + + it "discards an accepted conflict attempt and returns the rehydrated silent decision" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + conflictInserted <- newIORef False + let target = stream "domain-command-conflict-final-no-op" :: Stream RetryDecisionEventStream + targetStreamName = StreamName "domain-command-conflict-final-no-op" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, not inserted) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 9)) + appended <- + Store.runStoreIO storeHandle $ + Store.appendToStream targetStreamName NoStream [encoded] + case appended of + Right _ -> pure () + Left err -> expectationFailure ("failed to inject domain conflict: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryBackoffMicros + .~ 0 + callback _ _ = error "stale accepted decision invoked SQL callback" :: Tx.Transaction Text + outcome <- + runner $ + runDomainCommandWithSqlEvents + options + retryDecisionDomainHandler + target + (Add 1) + callback + case outcome of + Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do + explanation `shouldBe` "already drained" + result ^. #streamVersion `shouldBe` StreamVersion 1 + result ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected rehydrated no-op decision, got " <> show other) + readIORef conflictInserted `shouldReturn` True + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 9] + + it "records only bounded decision classes on successful spans and metrics" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions + (metricExporter, metricsRef) <- inMemoryMetricExporter + (meterProvider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just metricExporter} + meter <- getMeter meterProvider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let tracer = makeTracer tracerProvider "keiro-test" tracerOptions + options = + defaultRunCommandOptions + & #tracer + ?~ tracer + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runDomainCommand options multiCounterDomainHandler (stream "domain-telemetry-accepted") (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-rejected") RejectSilently + Right (Right _) <- + Store.runStoreIO storeHandle $ + runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-no-op") NoOpSilently + _ <- shutdownTracerProvider tracerProvider Nothing + _ <- forceFlushMeterProvider meterProvider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + fmap (\sp -> textAttr (csAttributes sp) "keiro.command.decision") spans + `shouldMatchList` [Just "accepted", Just "rejected", Just "no_op"] + fmap csStatus spans `shouldSatisfy` all (== Unset) + fmap (\sp -> textAttr (csAttributes sp) "error.type") spans + `shouldSatisfy` all (== Nothing) + exported <- readIORef metricsRef + let decisionPoints = + [ (textAttr attrs "keiro.command.decision", value) + | (name, value, attrs) <- flattenScalarPointsWithAttributes exported, + name == "keiro.command.decisions" + ] + decisionPoints + `shouldMatchList` [ (Just "accepted", IntNumber 1), + (Just "rejected", IntNumber 1), + (Just "no_op", IntNumber 1) + ] + + it "keeps all five process-manager target outcomes distinguishable" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + input = + DomainDispatchInput + "five-outcomes" + [ CoordinatorAccept 3, + CoordinatorReject "private rejection", + CoordinatorNoOp "private no-op", + CoordinatorUnmatched + ] + first <- + runner $ + runDomainProcessManagerOnce + defaultRunCommandOptions + domainProcessManager + sourceEvent + input + case first of + Right (Right result) -> do + result ^. #managerResult `shouldSatisfy` \case + PMStateAppended {} -> True + _ -> False + case result ^. #commandResults of + [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation}, + DomainPMCommandFailed _ CommandRejected + ] -> do + events `shouldBe` (CounterAdded 3 :| []) + reason `shouldBe` "private rejection" + explanation `shouldBe` "private no-op" + other -> expectationFailure ("expected four fresh domain PM outcomes, got " <> show other) + other -> expectationFailure ("expected domain process-manager success, got " <> show other) + second <- + runner $ + runDomainProcessManagerOnce + defaultRunCommandOptions + domainProcessManager + sourceEvent + input + case second of + Right (Right result) -> do + result ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate {} -> True + _ -> False + result ^. #commandResults `shouldSatisfy` \case + [ DomainPMCommandDuplicate {}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "private rejection"}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "private no-op"}, + DomainPMCommandFailed _ CommandRejected + ] -> True + _ -> False + other -> expectationFailure ("expected domain process-manager redelivery, got " <> show other) + + it "keeps all five router target outcomes distinguishable" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + input = + DomainDispatchInput + "five-outcomes" + [ CoordinatorAccept 4, + CoordinatorReject "router rejection", + CoordinatorNoOp "router no-op", + CoordinatorUnmatched + ] + Right (DomainRouterResult first) <- + runner $ + runDomainRouterOnce + defaultRunCommandOptions + domainRouter + sourceEvent + input + case first of + [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation}, + DomainPMCommandFailed _ CommandRejected + ] -> do + events `shouldBe` (CounterAdded 4 :| []) + reason `shouldBe` "router rejection" + explanation `shouldBe` "router no-op" + other -> expectationFailure ("expected four fresh domain router outcomes, got " <> show other) + Right (DomainRouterResult second) <- + runner $ + runDomainRouterOnce + defaultRunCommandOptions + domainRouter + sourceEvent + input + second `shouldSatisfy` \case + [ DomainPMCommandDuplicate {}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "router rejection"}, + DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "router no-op"}, + DomainPMCommandFailed _ CommandRejected + ] -> True + _ -> False + + it "acks domain rejection and no-op in coordinator workers without leaking payloads" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + processManagerDecisions <- newIORef [] + routerDecisions <- newIORef [] + let rejectionPayload = "pm-private-rejection-payload" + noOpPayload = "router-private-no-op-payload" + processManagerSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 1) + routerSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + processManagerInput = DomainDispatchInput "worker-pm" [CoordinatorReject rejectionPayload, CoordinatorNoOp "pm no-op"] + routerInput = DomainDispatchInput "worker-router" [CoordinatorReject "router rejection", CoordinatorNoOp noOpPayload] + processManagerAdapter = inMemoryAdapter processManagerDecisions [(processManagerSource, processManagerInput)] + routerAdapter = inMemoryAdapter routerDecisions [(routerSource, routerInput)] + workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics + commandOptions = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right () <- + runner $ + runDomainProcessManagerWorkerWith + workerOptions + commandOptions + domainProcessManager + processManagerAdapter + Just + Right () <- + runner $ + runDomainRouterWorkerWith + workerOptions + commandOptions + domainRouter + routerAdapter + Just + readIORef processManagerDecisions `shouldReturn` [AckOk] + readIORef routerDecisions `shouldReturn` [AckOk] + Right processManagerDeadLetters <- runner (listDispatchDeadLetters "domain-pm") + Right routerDeadLetters <- runner (listDispatchDeadLetters "domain-router") + processManagerDeadLetters `shouldBe` [] + routerDeadLetters `shouldBe` [] + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 0) + let rendered = Text.pack (show exported) + Text.isInfixOf rejectionPayload rendered `shouldBe` False + Text.isInfixOf noOpPayload rendered `shouldBe` False + + it "creates a stream and appends the first command event" $ \storeHandle -> do + let target = stream "counter-command-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2] + + it "reports no global position for a no-op after prior events" $ \storeHandle -> do + let target = stream "skip-command-no-op-position" :: Stream SkipEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target (SAdd 2) + appended ^. #globalPosition `shouldSatisfy` isJust + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions skipEventStream target SSkip + case result of + Right (Right noOp) -> do + noOp ^. #streamVersion `shouldBe` StreamVersion 1 + noOp ^. #eventsAppended `shouldBe` 0 + noOp ^. #globalPosition `shouldBe` Nothing + other -> expectationFailure ("expected successful no-op command, got " <> show other) + + it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-ambiguous" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + result <- + Store.runStoreIO storeHandle $ + runCommand options ambiguousCounterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + result `shouldBe` Right (Left (CommandAmbiguous [0, 1])) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous" + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rehydrates prior events before appending a second command event" $ \storeHandle -> do + let target = stream "counter-command-update" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected successful second command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + + it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-uncovered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 3) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 3) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 4) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do + let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream + targetName = StreamName "counter-truncated-mid-batch" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + case result of + Right (Left (HydrationGapDetected expected observed)) -> do + expected `shouldBe` StreamVersion 1 + observed `shouldBe` StreamVersion 2 + other -> expectationFailure ("expected HydrationGapDetected, got " <> show other) + + it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do + let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream + targetName = StreamName "counter-truncated-covered" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.setStreamTruncateBefore targetName (StreamVersion 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-covered command success, got " <> show other) + + it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do + let target = stream "counter-command-event-id" :: Stream CounterEventStream + supplied = EventId sampleUuid2 + options = defaultRunCommandOptions & #eventIds .~ [supplied] + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 7) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected successful command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied] + + it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do + conflictInserted <- newIORef False + let target = stream "counter-command-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-conflict" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = defaultRunCommandOptions & #beforeAppend .~ insertConflict + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected retry to succeed, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward conflictStreamName (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 10, CounterAdded 2] + + it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-exhausted-conflict" + insertConflict = do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName AnyVersion [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryLimit + .~ 2 + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (RetryExhausted attempts _)) -> + attempts `shouldBe` 3 + other -> expectationFailure ("expected exhausted retry budget, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2) + + it "records the successful retry attempt on the command span" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + conflictInserted <- newIORef False + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-retry-span" :: Stream CounterEventStream + conflictStreamName = StreamName "counter-command-retry-span" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted -> + if alreadyInserted + then (True, False) + else (True, True) + when shouldInsert $ do + encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10)) + outcome <- + Store.runStoreIO storeHandle $ + Store.appendToStream conflictStreamName NoStream [encoded] + case outcome of + Right _ -> pure () + Left err -> expectationFailure ("failed to insert conflict event: " <> show err) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConflict + & #retryBackoffMicros + .~ 0 + & #tracer + ?~ tracer + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2 + other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "counts duplicate deterministic command events" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let supplied = EventId sampleUuid3 + first = stream "counter-command-duplicate-a" :: Stream CounterEventStream + second = stream "counter-command-duplicate-b" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #eventIds + .~ [supplied] + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream first (Add 1) + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream second (Add 2) + case result of + Right (Left (StoreFailed Store.DuplicateEvent {})) -> pure () + other -> expectationFailure ("expected duplicate event failure, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #retryBackoffMicros + .~ 0 + & #metrics + ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.softDeleteStream (StreamName "counter-command-soft-deleted") + result <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 2) + case result of + Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists {})) -> pure () + other -> expectationFailure ("expected conflict fixpoint, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "surfaces decode failure during hydration" $ \storeHandle -> do + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-decode-failure") + NoStream + [ EventData + { eventId = Nothing, + eventType = EventType "OtherEvent", + payload = object [], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + ] + let target = stream "counter-command-decode-failure" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"]))) + + it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-no-inverting-edge" + target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAudited 7] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) + + it "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do + let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + appended ^. #streamVersion `shouldBe` StreamVersion 1 + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)) + + it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do + let target = stream "divert-black-acuity-good" :: Stream DivertEventStream + Right (Right appended) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + appended ^. #streamVersion `shouldBe` StreamVersion 1 + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> + expectationFailure ("expected hydration through the twin to succeed, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10 + traverse (decodeRecorded divertCodec) (Vector.toList recorded) + `shouldBe` Right [DivertConfirmed True, DivertConfirmed False] + + it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do + let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True) + result `shouldBe` Right (Left CommandRejected) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-queue-mismatch" + target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch)) + + it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-truncated-chain" + target = stream "counter-command-truncated-chain" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 5] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain)) + + it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do + let targetStreamName = StreamName "counter-command-ambiguous-inversion" + target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream + appendCounterEvents storeHandle targetStreamName [CounterAdded 3] + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1) + result + `shouldBe` Right + (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion)) + + it "truncates command span error status descriptions" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + longTag = Text.replicate 400 "x" + Right _ <- + Store.runStoreIO storeHandle $ + Store.appendToStream + (StreamName "counter-command-long-decode-failure") + NoStream + [ EventData + { eventId = Nothing, + eventType = EventType longTag, + payload = object [], + metadata = Just (metadataForOrDie 1 Nothing), + causationId = Nothing, + correlationId = Nothing + } + ] + let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + _ <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 1) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + case csStatus sp of + Error description -> Text.length description `shouldSatisfy` (<= 256) + other -> expectationFailure ("expected error span status, got " <> show other) + other -> expectationFailure ("expected one span, got " <> show (length other)) + + it "rolls back the append when inline SQL condemns the transaction" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-rollback" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSql + defaultRunCommandOptions + counterEventStream + target + (Add 1) + (\_ -> Tx.condemn >> pure ("rolled-back" :: Text)) + case result of + Right (Right (_, Just "rolled-back")) -> pure () + other -> expectationFailure ("expected condemned transaction result, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + + it "appends all events emitted by one accepted command" $ \storeHandle -> do + let target = stream "counter-command-multi-create" :: Stream CounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected successful multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 5, CounterAudited 5] + + it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (metricProvider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + (processor, spansRef) <- inMemoryListExporter + tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer tracerProvider "keiro-test" tracerOptions + target = stream "counter-command-replay-divergence" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #tracer + ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider metricProvider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + next <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3) + case next of + Right (Left HydrationReplayFailed {}) -> pure () + other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other) + _ <- shutdownTracerProvider tracerProvider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [sp] -> + textAttr (csAttributes sp) "keiro.replay.divergence" + `shouldBe` Just "event_index=0;reason=no_inverting_edge" + other -> expectationFailure ("expected one divergence span, got " <> show (length other)) + + it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #verifyReplayOnAppend + .~ False + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options headUnrecoverableEventStream target (Add 2) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Nothing + + it "witnesses replay divergence on the transactional SQL append path" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right (commandResult, Just ())) <- + runner $ + runCommandWithSqlEvents + options + headUnrecoverableEventStream + target + (Add 2) + (\_ _ -> pure ()) + commandResult ^. #eventsAppended `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported) + `shouldBe` Just (IntNumber 1) + + it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do + let target = stream "counter-command-multi-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2) + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected successful second multi-event command, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3] + + it "passes the complete multi-event batch to inline SQL in append order" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream + result <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + multiCounterEventStream + target + (Add 8) + (\pairs _ -> pure (Prelude.map Prelude.fst pairs)) + case result of + Right (Right (commandResult, Just observed)) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + observed `shouldBe` [CounterAdded 8, CounterAudited 8] + other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other) + + it "command metadata is merged into stored event metadata" $ \storeHandle -> do + let target = stream "counter-command-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand opts counterEventStream target (Add 4) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10 + case Vector.toList recorded of + [event] -> + event ^. #metadata + `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)]) + other -> expectationFailure ("expected a single recorded event, got " <> show other) + + it "reconstructed RecordedEvents match the stored batch" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right (_, Just pairs)) <- + runner $ + runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps) + let reconstructed = Prelude.map Prelude.snd pairs + -- Read the stored events back from their source stream. + Right storedVec <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10 + let stored = Vector.toList storedVec + -- readStreamForward reports globalPosition 0 for stream reads, so take + -- the true global positions from a category read (the DB is fresh per + -- test, so category "counter" holds exactly this batch). + Right catVec <- + Store.runStoreIO storeHandle $ + Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10 + let catList = Vector.toList catVec + Prelude.length reconstructed `shouldBe` 2 + Prelude.length stored `shouldBe` 2 + fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored + fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored + fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored + fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored + fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored + fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored + fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored + fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList + + it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + target = stream "counter-command-otel" :: Stream CounterEventStream + options = defaultRunCommandOptions & #tracer ?~ tracer + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options counterEventStream target (Add 9) + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + let sp = case spans of + (s : _) -> s + [] -> error "no command span captured" + csName sp `shouldBe` "counter-command-otel" + show (csKind sp) `shouldBe` "Internal" + textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel" + textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql" + -- keiro.events.appended is an Int64 attribute, not Text. + case lookupAttribute (csAttributes sp) "keiro.events.appended" of + Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1 + other -> expectationFailure ("expected IntAttribute 1, got " <> show other) + case csStatus sp of + Unset -> pure () + Ok -> pure () + other -> expectationFailure ("expected Unset/Ok, got " <> show other) + + describe "Keiro.Command enrichment parity" $ do + let addMarker eventData = pure (eventData & #metadata %~ injectMarker) + injectMarker = \case + Just (Aeson.Object fields) -> + Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields)) + _ -> Just (object ["enriched" Aeson..= True]) + installHook = #storeSettings . #enrichEvent ?~ addMarker + hasMarker = \case + Just (Aeson.Object fields) -> + KeyMap.lookup "enriched" fields == Just (Aeson.Bool True) + _ -> False + around (withFreshResourceStoreWith fixture installHook) $ + it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do + let plainTarget = stream "enrich-plain" :: Stream CounterEventStream + transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream + Right (Right _) <- + runner $ + runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1) + Right (Right (_, Just callbackRecordeds)) <- + runner $ + runCommandWithSqlEvents + defaultRunCommandOptions + counterEventStream + transactionalTarget + (Add 1) + (\pairs _ -> pure (fmap snd pairs)) + Right plainEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10 + Right transactionalEvents <- + runner $ + Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10 + for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + for_ callbackRecordeds $ \recorded -> + recorded ^. #metadata `shouldSatisfy` hasMarker + + describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do + it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do + result <- + encodeSnapshotStrict + (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + (Counting, emptyRegFile @SnapshotCounterRegs) + case result of + Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount" + Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot" + + it "writes a snapshot after policy threshold" $ \storeHandle -> do + let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 2, CounterAdded 3] + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 5) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4) + + it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + result <- + Store.runStoreIO storeHandle $ + runCommand options partialSnapshotEventStream target (Add 7) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 1 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10 + traverse (decodeRecorded counterCodec) (Vector.toList recorded) + `shouldBe` Right [CounterAdded 7] + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing + + it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "snapshot-tail-hydration", + (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode) + (Counting, RCons (Proxy @"lastAmount") 4 RNil) + ) + corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options guardedSnapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected snapshot-assisted command, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + + it "falls back when shape hash mismatches" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected stale shape fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-state-shape-change" + target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + lookupResult <- + Store.runStoreIO storeHandle $ + lookupSnapshotSeed + targetStreamName + (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1) + case lookupResult of + Right (SnapshotUnavailable SnapshotNotFound) -> pure () + _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot" + + it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup" + target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream + foldV1Codec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + foldV2Codec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec + case sameFingerprint of + Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2 + _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot" + changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec + case changedFingerprint of + Right (SnapshotUnavailable SnapshotNotFound) -> pure () + _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot" + + it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do + let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1 + withFold = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1") + withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion + withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash + + it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do + let targetStreamName = "snapshot-fold-fingerprint-e2e" + target = stream targetStreamName :: Stream SnapshotCounterEventStream + candidateCodec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + case Keiki.applyEventsEither + foldV2SnapshotCounterTransducer + (Counting, RCons (Proxy @"lastAmount") 0 RNil) + [CounterAdded 2, CounterAdded 3] of + Right (_, RCons _ fullReplayLastAmount RNil) -> + fullReplayLastAmount `shouldBe` 4 + Left failure -> + expectationFailure ("expected full replay under fold v2, got " <> show failure) + candidateResult <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104) + case candidateResult of + Right (Right result) -> do + result ^. #streamVersion `shouldBe` StreamVersion 3 + result ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other) + Right storedStateShape <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetStreamName snapshotStateShapeForStreamStmt + storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash) + + it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do + let targetStreamName = StreamName "snapshot-fold-manual-contract" + target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream + unchangedCodec = + defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec + case staleSeed of + Right (SnapshotHit seed) -> + case seed ^. #registers of + RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3 + _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed" + residualResult <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104) + residualResult `shouldBe` Right (Left CommandRejected) + + it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let targetName = "snapshot-seed-sampled-divergence" + target = stream targetName :: Stream SnapshotCounterEventStream + candidateStream :: ValidatedSnapshotCounterEventStream + candidateStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-sampled" + (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #seedVerifySampleRate + .~ 1 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + result <- + Store.runStoreIO storeHandle $ + runCommand options candidateStream target (Add 4) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other) + observed <- + timeout 5_000_000 $ + let awaitDivergence = do + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of + Just (IntNumber 1) -> pure () + _ -> threadDelay 10_000 >> awaitDivergence + in awaitDivergence + observed `shouldBe` Just () + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetName snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "disables sampled seed verification at rate zero" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let targetName = "snapshot-seed-sampling-disabled" + target = stream targetName :: Stream SnapshotCounterEventStream + candidateStream :: ValidatedSnapshotCounterEventStream + candidateStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-sampling-disabled" + (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never) + options = + defaultRunCommandOptions + & #metrics + ?~ keiroMetrics + & #seedVerifySampleRate + .~ 0 + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3) + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand options candidateStream target (Add 4) + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + threadDelay 100_000 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement targetName snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "falls back after operator truncation" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream + options = defaultRunCommandOptions & #metrics ?~ keiroMetrics + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "TRUNCATE keiro.keiro_snapshots" + result <- + Store.runStoreIO storeHandle $ + runCommand options snapshotCounterEventStream target (Add 4) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected truncation fallback, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3) + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing + + it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do + let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9) + case result of + Right (Right commandResult) -> do + commandResult ^. #streamVersion `shouldBe` StreamVersion 2 + commandResult ^. #eventsAppended `shouldBe` 2 + other -> expectationFailure ("expected multi-event snapshot command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do + let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream + boundaryEventStream :: SnapshotCounterEventStream + boundaryEventStream = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 3 + validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2) + Right firstSnapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + firstSnapshotVersion `shouldBe` Nothing + result <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3) + case result of + Right (Right commandResult) -> + commandResult ^. #streamVersion `shouldBe` StreamVersion 4 + other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other) + Right snapshotVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 4) + + it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do + let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4) + Right snapshotVersionBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionBefore `shouldBe` Just (StreamVersion 4) + let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2 + streamId <- + Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case + Right (Just sid) -> pure sid + other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + writeSnapshotRow + SnapshotWrite + { streamId = streamId, + streamVersion = StreamVersion 2, + state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil), + stateCodecVersion = rollbackCodec ^. #stateCodecVersion, + regfileShapeHash = rollbackCodec ^. #shapeHash, + stateShapeHash = rollbackCodec ^. #stateShapeHash + } + Right snapshotVersionAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt + snapshotVersionAfter `shouldBe` Just (StreamVersion 2) + + describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do + it "accepts only stream names in the configured category" $ \_ -> do + ReplayAudit.streamInCategory "counter" (StreamName "counter-one") + `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ())) + ReplayAudit.streamInCategory "counter" (StreamName "other-one") + `shouldBe` (Nothing :: Maybe (Stream ())) + + it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do + let affectedTarget = + stream "auditremove-affected" :: Stream CounterEventStream + unaffectedTarget = + stream "auditremove-unaffected" :: Stream CounterEventStream + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "CounterAdded"), + includeSnapshotStreams = False + } + budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 + candidateTarget = + ReplayAudit.AuditTarget + { eventStream = auditedCounterEventStream, + category = "auditremove", + mkStream = Just . Stream.Stream + } + deployedTarget = + ReplayAudit.AuditTarget + { eventStream = counterEventStream, + category = "auditremove", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9) + + Right candidateReport <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + candidateTarget + candidateReport ^. #streamsSelected `shouldBe` 1 + candidateReport ^. #streamsSkipped `shouldBe` 1 + candidateReport ^. #failures `shouldBe` 1 + candidateReport ^. #divergences `shouldBe` 0 + candidateReport ^. #rejectedStreams `shouldBe` [] + case candidateReport ^. #results of + [ ReplayAudit.StreamAuditResult + _ + ( ReplayAudit.ReplayFailed + (HydrationReplayFailed _ HydrationNoInvertingEdge) + ) + ] -> pure () + other -> + expectationFailure + ("expected a no-inverting-edge audit failure, got " <> show other) + + Right deployedReport <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + deployedTarget + ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0 + + Right eventsAfterAudit <- + Store.runStoreIO storeHandle $ + Store.readStreamForward + (StreamName "auditremove-affected") + (StreamVersion 0) + 10 + Vector.length eventsAfterAudit `shouldBe` 1 + + it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do + let target = stream "divert-audit-replay-only" :: Stream DivertEventStream + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "DivertConfirmed"), + includeSnapshotStreams = False + } + budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1 + auditWith candidate = + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + budget + ReplayAudit.AuditTarget + { eventStream = candidate, + category = "divert", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True) + + Right withoutTwin <- + Store.runStoreIO storeHandle $ + auditWith tightenedDivertEventStream + withoutTwin ^. #results + `shouldBe` [ ReplayAudit.StreamAuditResult + (StreamName "divert-audit-replay-only") + ( ReplayAudit.ReplayFailed + (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge) + ) + ] + ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1 + + Right withTwin <- + Store.runStoreIO storeHandle $ + auditWith twinDivertEventStream + withTwin ^. #results + `shouldBe` [ ReplayAudit.StreamAuditResult + (StreamName "divert-audit-replay-only") + ReplayAudit.ReplayOk + { ReplayAudit.streamVersion = StreamVersion 1, + ReplayAudit.digest = Nothing + } + ] + ReplayAudit.auditExitCode [withTwin] `shouldBe` 0 + + it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do + let target = + stream "auditfold-stale" :: Stream SnapshotCounterEventStream + auditTarget = + ReplayAudit.AuditTarget + { eventStream = foldV2WithoutFingerprintBumpEventStream, + category = "auditfold", + mkStream = Just . Stream.Stream + } + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8) + + Right outcome <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStream auditTarget target + case outcome of + ReplayAudit.SeedDivergence + { seedVersion = StreamVersion 2, + seededDigest, + fullDigest + } -> + seededDigest `shouldNotBe` fullDigest + other -> + expectationFailure + ("expected a stale-seed divergence, got " <> show other) + + it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do + let targets = + [ stream "auditclean-one" :: Stream SnapshotCounterEventStream, + stream "auditclean-two" :: Stream SnapshotCounterEventStream + ] + affected = + ReplayAudit.AffectedSet + { affectedEventTypes = Set.singleton (EventType "CounterAdded"), + includeSnapshotStreams = False + } + auditTarget = + ReplayAudit.AuditTarget + { eventStream = snapshotCounterEventStream, + category = "auditclean", + mkStream = Just . Stream.Stream + } + unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2 + for_ (zip targets [10, 20]) $ \(target, amount) -> do + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1)) + pure () + + Right firstFull <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget + Right secondFull <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget + firstFull ^. #streamsSelected `shouldBe` 2 + firstFull ^. #streamsSkipped `shouldBe` 0 + firstFull ^. #results `shouldBe` secondFull ^. #results + + Right firstPage <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + (unbounded & #maxStreams ?~ 1) + auditTarget + firstPage ^. #streamsSelected `shouldBe` 1 + firstPage ^. #checkpoint `shouldSatisfy` isJust + Right secondPage <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + ( unbounded + & #maxStreams + ?~ 1 + & #resumeFrom + .~ (firstPage ^. #checkpoint) + ) + auditTarget + secondPage ^. #streamsSelected `shouldBe` 1 + let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results) + secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results) + Set.disjoint firstNames secondNames `shouldBe` True + firstNames <> secondNames + `shouldBe` Set.fromList (Stream.streamName <$> targets) + + Right targeted <- + Store.runStoreIO storeHandle $ + ReplayAudit.auditStreams + (ReplayAudit.AuditTargeted affected) + unbounded + auditTarget + targeted ^. #results `shouldBe` firstFull ^. #results + + describe "Keiro.Connection projection schema" $ + around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do + it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do + -- qualifiedTableName builds the app's fully-qualified data table ref. + qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\"" + + -- Create the app schema (opt-in) and the qualified read-model table. + Right () <- + Store.runStoreIO storeHandle $ do + ensureProjectionSchema "app_reads" + initializeRegisteredReadModel placedReadModel initializePlacedTable + + -- Drive a command with the inline projection that writes the app table. + let target = stream "placed-in-app-reads" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 7) + [placedInlineProjection] + case result of + Right (Right _) -> pure () + other -> expectationFailure ("expected placed inline projection command, got " <> show other) + + -- Read it back through the configured-schema read model. + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing placedReadModel "placed" + queryResult `shouldBe` Right (Right 7) + + -- Prove placement: the app table is in app_reads, NOT in kiroku, and + -- Keiro's own metadata (keiro_read_models) is in the keiro schema. + Right (inApp, inKiroku, keiroMeta) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + (,,) + <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt + <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt + <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt + inApp `shouldBe` (1 :: Int) + inKiroku `shouldBe` (0 :: Int) + keiroMeta `shouldBe` (1 :: Int) + + describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do + it "queries inline projection with Eventual consistency" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline" :: Stream CounterEventStream + result <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + case result of + Right (Right commandResult) -> + commandResult ^. #globalPosition `shouldSatisfy` isJust + other -> expectationFailure ("expected inline projection command, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness Nothing Immediate counterImmediateReadModel "inline" + truthfulResult `shouldBe` queryResult + + it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt + Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt + position <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + position `shouldBe` Right (Just (GlobalPosition 3)) + + it "returns no subscription position for an empty durable inventory" $ \_ -> do + let inventory = + KirokuSub.SubscriptionCheckpointInventory + (GlobalPosition 17) + Vector.empty + subscriptionPositionFromInventory (SubscriptionName "missing") inventory + `shouldBe` Nothing + + it "returns the newest visible position after a stream is hard deleted" $ \storeHandle -> do + let target = stream "read-model-captured-head" :: Stream CounterEventStream + Right (Right commandResult) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + capturedPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.hardDeleteStream (StreamName "read-model-captured-head") + observedHead <- Store.runStoreIO storeHandle storeHeadPosition + observedHead `shouldBe` Right (GlobalPosition 0) + Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <- + Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory + authoritativePosition `shouldBe` capturedPosition + + it "Strong returns immediately on an empty log" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "empty" + queryResult `shouldBe` Right (Right 0) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForHead EntireVisibleLog) + counterCursorReadModel + "empty" + truthfulResult `shouldBe` queryResult + + it "rejects truthful waits when an immediate inline model has no cursor" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForHead EntireVisibleLog) + counterImmediateReadModel + "inline" + queryResult + `shouldBe` Right + ( Left + ( ReadModelMissingCursor + "counter-read-model" + (WaitForHead EntireVisibleLog) + ) + ) + + it "waitFor fails fast on a cursorless model instead of burning the timeout" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + startedAt <- getCurrentTime + waitResult <- + Store.runStoreIO storeHandle $ + waitFor (Just keiroMetrics) defaultHeadWaitOptions counterImmediateReadModel (GlobalPosition 5) + finishedAt <- getCurrentTime + waitResult + `shouldBe` Right + ( Left + ( ReadModelMissingCursor + "counter-read-model" + (WaitForPosition (defaultHeadWaitOptions & #target ?~ GlobalPosition 5)) + ) + ) + diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing + + it "deprecated Strong and PositionWait overrides fail fast on a cursorless model" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable + let target = stream "read-model-cursorless-strong" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 5) + startedAt <- getCurrentTime + strongResult <- + Store.runStoreIO storeHandle $ + runQueryWith (Just keiroMetrics) Strong counterImmediateReadModel "inline" + finishedAt <- getCurrentTime + strongResult + `shouldBe` Right + (Left (ReadModelMissingCursor "counter-read-model" (WaitForHead EntireVisibleLog))) + diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness Nothing (WaitForHead EntireVisibleLog) counterImmediateReadModel "inline" + truthfulResult `shouldBe` strongResult + positionResult <- + Store.runStoreIO storeHandle $ + runQueryWith + (Just keiroMetrics) + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterImmediateReadModel + "inline" + positionResult + `shouldBe` Right + ( Left + ( ReadModelMissingCursor + "counter-read-model" + (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + ) + ) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing + + it "Strong returns immediately when the subscription is already at the store head" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-at-head" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 5) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 5) + + it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-strong-blocking" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 6) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + _ <- forkIO $ do + threadDelay 20000 + advanced <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + case advanced of + Right () -> pure () + Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult `shouldBe` Right (Right 6) + + it "Strong and WaitForHead return promptly after workflow GC hard-deletes the newest events" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + (stream "read-model-gc-strong" :: Stream CounterEventStream) + (Add 5) + [counterInlineProjection] + visiblePosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("counter-read-model-sub", globalPositionToInt visiblePosition) + upsertSubscriptionCursorStmt + + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + (WorkflowName "gc-strong-wf") + (WorkflowId "gsw-1") + (demoWorkflow counter) + now <- getCurrentTime + Right summary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} + + observedHead <- Store.runStoreIO storeHandle storeHeadPosition + observedHead `shouldBe` Right visiblePosition + Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <- + Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory + authoritativePosition `shouldSatisfy` (> visiblePosition) + + startedAt <- getCurrentTime + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + finishedAt <- getCurrentTime + queryResult `shouldBe` Right (Right 5) + diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2) + + truthfulStartedAt <- getCurrentTime + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForHead EntireVisibleLog) + counterCursorReadModel + "inline" + truthfulFinishedAt <- getCurrentTime + truthfulResult `shouldBe` queryResult + diffUTCTime truthfulFinishedAt truthfulStartedAt `shouldSatisfy` (< 2) + + it "Strong and WaitForHead still time out when visible events outrun the subscription" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + (stream "read-model-strong-visible-behind" :: Stream CounterEventStream) + (Add 5) + [counterInlineProjection] + visiblePosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterReadModel "inline" + queryResult + `shouldBe` Right + ( Left + ( ReadModelWaitTimeout + "counter-read-model" + visiblePosition + (GlobalPosition 0) + ) + ) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForHead EntireVisibleLog) + counterCursorReadModel + "inline" + truthfulResult `shouldBe` queryResult + + it "Strong and WaitForHead return when their category is caught up despite another active category" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream + otherTarget = stream "otherload-1" :: Stream CounterEventStream + Right (Right counterResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + counterTarget + (Add 8) + [counterInlineProjection] + counterPosition <- case counterResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected counter global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("counter-read-model-sub", globalPositionToInt counterPosition) + upsertSubscriptionCursorStmt + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1) + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith Nothing Strong counterCategoryReadModel "inline" + queryResult `shouldBe` Right (Right 8) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForHead (CategoryVisibleHead "counter")) + counterCursorReadModel + "inline" + truthfulResult `shouldBe` queryResult + + it "inline projection populates actor and source_event_id from command metadata" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-inline-metadata" :: Stream CounterEventStream + opts = + defaultRunCommandOptions + & #metadata + ?~ object ["actor" Aeson..= ("agent-7" :: Text)] + Right (Right _) <- + runner $ + runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection] + Right row <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt) + -- selectCounterMetaStmt returns (amount, actor, source_event_id). + row `shouldSatisfy` \(amount, actor, srcId) -> + amount == 5 && actor == Just "agent-7" && isJust srcId + + it "waits for async projection cursor with PositionWait" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-position-wait" :: Stream CounterEventStream + Right (Right commandResult) <- + runner $ + runCommandWithProjections + defaultRunCommandOptions + counterEventStream + target + (Add 3) + [counterInlineProjection] + globalPosition <- case commandResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected command global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just globalPosition)) + counterReadModel + "inline" + queryResult `shouldBe` Right (Right 3) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForPosition (fastWaitOptions & #target .~ Just globalPosition)) + counterCursorReadModel + "inline" + truthfulResult `shouldBe` queryResult + + it "times out when PositionWait target is not reached" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + Nothing + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + truthfulResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterCursorReadModel + "timeout" + truthfulResult `shouldBe` queryResult + + it "rejects a truthful position wait without a target" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterCursorReadModel initializeCounterReadModelTable + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWithFreshness + Nothing + (WaitForPosition fastWaitOptions) + counterCursorReadModel + "missing-target" + queryResult + `shouldBe` Right (Left (ReadModelMissingPosition "counter-read-model")) + + it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminBefore <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "no-churn" + Right xminAfter <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "counter-read-model" readModelXminStmt + xminAfter `shouldBe` xminBefore + + it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do + let unregistered :: ReadModel Text Int + unregistered = counterReadModel & #name .~ ("never-registered" :: Text) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing unregistered "missing" + queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered")) + found <- + Store.runStoreIO storeHandle $ + lookupReadModel "never-registered" + found `shouldBe` Right Nothing + + it "handles concurrent explicit read-model registration" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeCounterReadModelTable + resultA <- newEmptyMVar + resultB <- newEmptyMVar + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultA + _ <- + forkIO $ + Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel) + >>= putMVar resultB + first <- takeMVar resultA + second <- takeMVar resultB + first `shouldBe` Right () + second `shouldBe` Right () + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "concurrent" + queryResult `shouldBe` Right (Right 0) + + it "rejects stale read-model schema" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "stale" + queryResult + `shouldBe` Right + (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1")) + + it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right (Right 0) <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "unknown-status" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged"))) + + it "ignores duplicate async event by source_event_id" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-async-idempotent" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right outcomes <- Store.runStoreIO storeHandle $ + Store.runTransaction $ do + first <- applyAsyncProjection counterAsyncProjection event + second <- applyAsyncProjection counterAsyncProjection event + pure (first, second) + outcomes `shouldBe` (AsyncApplied, AsyncDuplicate) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction initializeProjectionDedupCounterTable + Right _ <- + Store.runStoreIO storeHandle $ + registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1" + let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + let incrementingProjection = + AsyncProjection + { name = "incrementing-async-projection", + readModelName = "projection-dedup-counter-model", + subscriptionName = "incrementing-async-projection-sub", + applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt, + idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId + } + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right AsyncDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterDuplicate <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterDuplicate `shouldBe` 1 + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection incrementingProjection event + Right countAfterPrune <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () selectProjectionDedupCounterStmt + countAfterPrune `shouldBe` 2 + + it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ( "counter-read-model-sub", + globalPositionToInt (event ^. #globalPosition) + ) + upsertSubscriptionCursorStmt + beforeRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + beforeRebuild `shouldBe` Right (Right 7) + + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + rebuilding ^. #status `shouldBe` Rebuilding + checkpointAfterReset <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0)) + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right live) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + live ^. #status `shouldBe` Live + + afterRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + afterRebuild `shouldBe` Right (Right 7) + + it "startRebuild on a cursorless model skips the checkpoint reset and completes" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel + counterCursorlessRebuildReadModel + initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.sql "INSERT INTO counter_read_model (model_id, amount, last_seen) VALUES ('inline', 9, 1)" + Tx.statement ("counter-read-model-sub", 7) upsertSubscriptionCursorStmt + rebuildingResult <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0) + rebuilding <- case rebuildingResult of + Right metadata -> pure metadata + Left err -> expectationFailure ("cursorless startRebuild failed: " <> show err) *> error "unreachable" + rebuilding ^. #status `shouldBe` Rebuilding + untouched <- + Store.runStoreIO storeHandle $ + readSubscriptionPosition "counter-read-model-sub" + untouched `shouldBe` Right (Just (GlobalPosition 7)) + Right (Right live) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0) + live ^. #status `shouldBe` Live + afterRebuild <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterCursorlessRebuildReadModel "inline" + afterRebuild `shouldBe` Right (Right 0) + + it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + finishResult <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + case finishResult of + Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do + modelName `shouldBe` "counter-read-model" + headPosition `shouldSatisfy` (> GlobalPosition 0) + other -> expectationFailure ("expected zero-apply guard, got " <> show other) + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult + `shouldBe` Right + (Left (ReadModelNotLive "counter-read-model" Rebuilding)) + + it "fences live async application while a model is rebuilding" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fenced-apply" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + outcome <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + outcome `shouldBe` Right AsyncFenced + Right dedupCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt + dedupCount `shouldBe` 0 + Right amount <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "async-idempotent" selectCounterReadModelStmt + amount `shouldBe` 0 + + it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-fence-race" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 7) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10 + event <- case Vector.toList recorded of + [onlyEvent] -> pure onlyEvent + other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable" + enterRebuildWindow <- newEmptyMVar + liveApplyResult <- newEmptyMVar + _ <- + forkIO $ do + takeMVar enterRebuildWindow + Store.runStoreIO + storeHandle + (Store.runTransaction (applyAsyncProjection counterAsyncProjection event)) + >>= putMVar liveApplyResult + Right _ <- + Store.runStoreIO storeHandle $ + Rebuild.startRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + putMVar enterRebuildWindow () + takeMVar liveApplyResult `shouldReturn` Right AsyncFenced + + Right AsyncApplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjectionUnfenced counterAsyncProjection event + Right (Right _) <- + Store.runStoreIO storeHandle $ + Rebuild.finishRebuild + counterReadModel + [counterAsyncProjection ^. #name] + (GlobalPosition 0) + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff + pruned `shouldBe` Right 1 + reapplied <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + applyAsyncProjection counterAsyncProjection event + reapplied `shouldBe` Right AsyncApplied + queryResult <- + Store.runStoreIO storeHandle $ + runQuery Nothing counterReadModel "async-idempotent" + queryResult `shouldBe` Right (Right 7) + + it "tracks rebuild state transitions" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + registerReadModelDefinition counterReadModel + Right rebuilding <- + Store.runStoreIO storeHandle $ + Rebuild.rebuild counterReadModel + rebuilding ^. #status `shouldBe` Rebuilding + Right live <- + Store.runStoreIO storeHandle $ + Rebuild.promote counterReadModel + live ^. #status `shouldBe` Live + Right abandoned <- + Store.runStoreIO storeHandle $ + Rebuild.abandonRebuild counterReadModel + abandoned ^. #status `shouldBe` Abandoned + + it "records matching global position distance and projection lag gauges" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + let target = stream "read-model-lag" :: Stream CounterEventStream + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand defaultRunCommandOptions counterEventStream target (Add 1) + -- The subscription cursor is never advanced, so both the preferred and + -- compatibility gauges record the same non-negative position distance. + Right () <- + Store.runStoreIO storeHandle $ + recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + preferred = lookup "keiro.projection.global_position_distance" scalars + compatibility = lookup "keiro.projection.lag" scalars + preferred `shouldBe` compatibility + case preferred of + Just (IntNumber n) -> n `shouldSatisfy` (>= 1) + other -> expectationFailure ("expected an integer global position distance, got " <> show other) + + it "reports zero global position distance after the newest events are hard deleted" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right (Right survivorResult) <- + Store.runStoreIO storeHandle $ + runCommand + defaultRunCommandOptions + counterEventStream + (stream "gauge-gc-survivor" :: Stream CounterEventStream) + (Add 1) + survivorPosition <- case survivorResult ^. #globalPosition of + Just position -> pure position + Nothing -> expectationFailure "expected survivor global position" *> error "unreachable" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("counter-read-model-sub", globalPositionToInt survivorPosition) + upsertSubscriptionCursorStmt + Right (Right _) <- + Store.runStoreIO storeHandle $ + runCommand + defaultRunCommandOptions + counterEventStream + (stream "gauge-gc-victim" :: Stream CounterEventStream) + (Add 1) + Right (Just _) <- + Store.runStoreIO storeHandle $ + Store.hardDeleteStream (StreamName "gauge-gc-victim") + Right () <- + Store.runStoreIO storeHandle $ + recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.projection.global_position_distance" scalars + `shouldBe` Just (IntNumber 0) + lookup "keiro.projection.lag" scalars + `shouldBe` Just (IntNumber 0) + + it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt + queryResult <- + Store.runStoreIO storeHandle $ + runQueryWith + (Just keiroMetrics) + (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5))) + counterReadModel + "timeout" + queryResult + `shouldBe` Right + (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1))) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The single give-up bumped the counter exactly once. + lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1) + + describe "process reaction API feasibility" $ do + it "keeps the supplied witness on the first event of an accepted multi-event batch" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "reaction-feasibility-multi" :: Stream CounterEventStream + targetName = StreamName "reaction-feasibility-multi" + witnessId = EventId sampleUuid + options = defaultRunCommandOptions & #eventIds .~ [witnessId] + outcome <- + runner $ + runDomainCommandWithSqlEvents + options + multiCounterDomainHandler + target + (Add 7) + (\pairs _ -> pure (Prelude.snd <$> pairs)) + case outcome of + Right (Right (DomainCommandOutcome {decision = DomainAccepted events}, Just persisted)) -> do + events `shouldBe` (CounterAdded 7 :| [CounterAudited 7]) + fmap (^. #eventId) persisted `shouldSatisfy` \case + firstId : secondId : [] -> firstId == witnessId && secondId /= witnessId + _ -> False + other -> expectationFailure ("expected accepted feasibility batch, got " <> show other) + Right firstPage <- runner $ Store.readStreamForward targetName (StreamVersion 0) 1 + case Vector.toList firstPage of + [witness] -> do + witness ^. #eventId `shouldBe` witnessId + decodeRecorded counterCodec witness `shouldBe` Right (CounterAdded 7) + other -> expectationFailure ("expected one witness event, got " <> show other) + + it "runs no accepted callback from an optimistic attempt discarded by rehydration" $ \_ -> + withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do + conflictInserted <- newIORef False + let target = stream "reaction-feasibility-conflict" :: Stream RetryDecisionEventStream + targetName = StreamName "reaction-feasibility-conflict" + insertConflict = do + shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, Prelude.not inserted) + when shouldInsert $ appendCounterEventWithId storeHandle targetName (EventId sampleUuid2) (CounterAdded 9) + options = + defaultRunCommandOptions + & #eventIds + .~ [EventId sampleUuid] + & #beforeAppend + .~ insertConflict + & #retryBackoffMicros + .~ 0 + callback _ _ = error "discarded feasibility attempt ran its callback" :: Tx.Transaction () + outcome <- runner $ runDomainCommandWithSqlEvents options retryDecisionDomainHandler target (Add 1) callback + case outcome of + Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do + explanation `shouldBe` "already drained" + result ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected rehydrated silent feasibility decision, got " <> show other) + + it "exposes one accepted and one rehydrated-silent result when the same source races" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + arrivals <- newMVar (0 :: Int) + release <- newEmptyMVar + firstResult <- newEmptyMVar + secondResult <- newEmptyMVar + let target = stream "reaction-feasibility-same-source" :: Stream RetryDecisionEventStream + witnessId = EventId sampleUuid + awaitPeer = do + arrived <- modifyMVar arrivals $ \count -> + let next = count + 1 + in pure (next, next) + when (arrived == 2) (putMVar release ()) + readMVar release + options = + defaultRunCommandOptions + & #eventIds + .~ [witnessId] + & #beforeAppend + .~ awaitPeer + & #retryBackoffMicros + .~ 0 + runOne destination = + runner + ( runDomainCommandWithSqlEvents + options + retryDecisionDomainHandler + target + (Add 3) + (\_ _ -> pure ()) + ) + >>= putMVar destination + _ <- forkIO (runOne firstResult) + _ <- forkIO (runOne secondResult) + outcomes <- traverse takeMVar [firstResult, secondResult] + let accepted = + Prelude.length + [ () + | Right (Right (DomainCommandOutcome {decision = DomainAccepted {}}, Just ())) <- outcomes + ] + silent = + Prelude.length + [ () + | Right (Right (DomainCommandOutcome {decision = DomainNoOp "already drained"}, Nothing)) <- outcomes + ] + (accepted, silent) `shouldBe` (1, 1) + + it "allows a receipt-free silent delivery to accept after unrelated saga progress" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "reaction-feasibility-silent-redelivery" :: Stream FeasibilityGateEventStream + witnessId = EventId sampleUuid + sourceOptions = defaultRunCommandOptions & #eventIds .~ [witnessId] + first <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 5) + case first of + Right (Right DomainCommandOutcome {decision = DomainNoOp "gate closed", result}) -> + result ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected initial silent feasibility decision, got " <> show other) + Right (Right DomainCommandOutcome {decision = DomainAccepted (GateOpened :| [])}) <- + runner $ runDomainCommand defaultRunCommandOptions feasibilityGateDomainHandler target OpenGate + redelivery <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 5) + case redelivery of + Right (Right DomainCommandOutcome {decision = DomainAccepted (GateAccepted 5 :| [])}) -> pure () + other -> expectationFailure ("expected accepted silent redelivery, got " <> show other) + + it "shows that a negative silent probe cannot fence a later unconditional timer transaction" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + probeReady <- newEmptyMVar + releaseTimer <- newEmptyMVar + silentResult <- newEmptyMVar + let target = stream "reaction-feasibility-silent-timer-race" :: Stream FeasibilityGateEventStream + targetName = StreamName "reaction-feasibility-silent-timer-race" + witnessId = EventId sampleUuid + sourceOptions = defaultRunCommandOptions & #eventIds .~ [witnessId] + request = + counterTimerRequest + & #timerId + .~ TimerId sampleUuid2 + & #processManagerName + .~ "reaction-feasibility" + runSilentBranch = do + silent <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 9) + probe <- runner $ firstExistingEventId sourceOptions targetName (witnessId :| []) + putMVar probeReady (silent, probe) + takeMVar releaseTimer + scheduled <- runner $ Store.runTransaction (scheduleTimerOnceTx request) + putMVar silentResult scheduled + _ <- forkIO runSilentBranch + (initial, negativeProbe) <- takeMVar probeReady + case initial of + Right (Right DomainCommandOutcome {decision = DomainNoOp "gate closed"}) -> pure () + other -> expectationFailure ("expected silent branch before probe, got " <> show other) + negativeProbe `shouldBe` Right Nothing + Right (Right _) <- runner $ runDomainCommand defaultRunCommandOptions feasibilityGateDomainHandler target OpenGate + Right (Right DomainCommandOutcome {decision = DomainAccepted (GateAccepted 9 :| [])}) <- + runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 9) + putMVar releaseTimer () + takeMVar silentResult `shouldReturn` Right True + timer <- runner $ lookupTimer (request ^. #timerId) + timer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Scheduled + _ -> False + + it "cancels a timer in the same transaction as an accepted saga append" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "reaction-feasibility-cancel-accepted" :: Stream CounterEventStream + request = counterTimerRequest & #timerId .~ TimerId sampleUuid2 + Right () <- runner $ Store.runTransaction (scheduleTimerTx request) + outcome <- + runner $ + runDomainCommandWithSqlEvents + defaultRunCommandOptions + multiCounterDomainHandler + target + (Add 2) + (\_ _ -> cancelTimerTx (request ^. #timerId)) + case outcome of + Right (Right (DomainCommandOutcome {decision = DomainAccepted {}}, Just True)) -> pure () + other -> expectationFailure ("expected accepted append and timer cancellation, got " <> show other) + runner (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing + timer <- runner $ lookupTimer (request ^. #timerId) + timer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Timer.Cancelled + _ -> False + + it "rolls back both an accepted saga append and transactional cancellation when condemned" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let target = stream "reaction-feasibility-cancel-rollback" :: Stream CounterEventStream + targetName = StreamName "reaction-feasibility-cancel-rollback" + request = counterTimerRequest & #timerId .~ TimerId sampleUuid2 + Right () <- runner $ Store.runTransaction (scheduleTimerTx request) + outcome <- + runner $ + runDomainCommandWithSqlEventsControlled + defaultRunCommandOptions + multiCounterDomainHandler + target + (Add 4) + ( \_ _ -> do + cancelled <- cancelTimerTx (request ^. #timerId) + pure (RollbackSqlTransaction cancelled) + ) + outcome `shouldBe` Right (Right (DomainSqlCommandRolledBack True)) + Right recorded <- runner $ Store.readStreamForward targetName (StreamVersion 0) 10 + recorded `shouldBe` Vector.empty + timer <- runner $ lookupTimer (request ^. #timerId) + timer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Scheduled + _ -> False + + it "keeps transactional cancellation idempotent and protects terminal and foreground-owned rows" $ \_ -> + withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do + let request n = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n) + cancelledRequest = request 101 + firedRequest = request 102 + liveClaimRequest = request 103 + expiredClaimRequest = request 104 + absentRequest = request 105 + claimRequest timerRequest leaseSeconds = + DeadTimerClaimRequest + (timerRequest ^. #timerId) + (timerRequest ^. #processManagerName) + "reaction-feasibility" + 3 + leaseSeconds + setupForeground timerRequest leaseSeconds = do + Right () <- runner $ Store.runTransaction (scheduleTimerTx timerRequest) + Right True <- runner $ deadLetterTimer (timerRequest ^. #timerId) "reaction-feasibility" + Right (Right _) <- runner $ claimDeadTimer (claimRequest timerRequest leaseSeconds) + pure () + Right () <- runner $ Store.runTransaction $ do + scheduleTimerTx cancelledRequest + scheduleTimerTx firedRequest + runner (cancelTimer (cancelledRequest ^. #timerId)) `shouldReturn` Right True + runner (Store.runTransaction (cancelTimerTx (cancelledRequest ^. #timerId))) `shouldReturn` Right False + Right (Just _) <- runner $ claimDueTimer dueTimerTime + runner (markTimerFired (firedRequest ^. #timerId) (EventId sampleUuid3)) `shouldReturn` Right True + runner (Store.runTransaction (cancelTimerTx (firedRequest ^. #timerId))) `shouldReturn` Right False + setupForeground liveClaimRequest 60 + runner (Store.runTransaction (cancelTimerTx (liveClaimRequest ^. #timerId))) `shouldReturn` Right False + setupForeground expiredClaimRequest 1 + threadDelay 1_100_000 + runner (Store.runTransaction (cancelTimerTx (expiredClaimRequest ^. #timerId))) `shouldReturn` Right False + runner (Store.runTransaction (cancelTimerTx (absentRequest ^. #timerId))) `shouldReturn` Right False + runner (Store.runTransaction (scheduleTimerOnceTx absentRequest)) `shouldReturn` Right True + timer <- runner $ lookupTimer (absentRequest ^. #timerId) + timer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Scheduled + _ -> False + + describe "Keiro.ProcessManager.Reaction" $ around (withFreshResourceStore fixture) $ do + it "commits accepted saga timers before ordered target fan-out and recovers duplicates" $ \(_storeHandle, StoreRunner runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 5) + target = stream "reaction-target:accepted" :: Stream CounterCommand + rearmRequest = counterTimerRequest & #timerId .~ TimerId sampleUuid2 & #payload .~ object ["mode" Aeson..= ("rearm" :: Text)] + onceRequest = counterTimerRequest & #timerId .~ TimerId sampleUuid3 & #payload .~ object ["mode" Aeson..= ("once" :: Text)] + plan = + Reaction.AdvanceReaction + (Add 5) + [ Reaction.FollowSchedule Reaction.Rearm rearmRequest, + Reaction.FollowDispatch (PMCommand target (Add 5)) + ] + [ Reaction.FollowSchedule Reaction.Once onceRequest, + Reaction.FollowDispatch (PMCommand target (Add 6)) + ] + input = ("accepted", plan) + first <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent input + case first of + Right (Right result) -> do + result ^. #managerResult `shouldSatisfy` \case + Reaction.ReactionEvaluated DomainCommandOutcome {decision = DomainAccepted (CounterAdded 5 :| [CounterAudited 5])} -> True + _ -> False + result ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended a, PMCommandAppended b] -> a ^. #eventsAppended == 1 && b ^. #eventsAppended == 1 + _ -> False + result ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 1 0 + other -> expectationFailure ("expected accepted reaction, got " <> show other) + beforeRearm <- runner $ lookupTimer (rearmRequest ^. #timerId) + beforeOnce <- runner $ lookupTimer (onceRequest ^. #timerId) + duplicate <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent input + case duplicate of + Right (Right result) -> do + result ^. #managerResult `shouldSatisfy` \case + Reaction.ReactionDuplicate {} -> True + _ -> False + result ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate {}, PMCommandDuplicate {}] -> True + _ -> False + result ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 0 0 0 + other -> expectationFailure ("expected duplicate reaction recovery, got " <> show other) + runner (lookupTimer (rearmRequest ^. #timerId)) `shouldReturn` beforeRearm + runner (lookupTimer (onceRequest ^. #timerId)) `shouldReturn` beforeOnce + Right sagaEvents <- runner $ Store.readStreamForward (StreamName "reaction-saga:accepted") (StreamVersion 0) 10 + Right targetEvents <- runner $ Store.readStreamForward (StreamName "reaction-target:accepted") (StreamVersion 0) 10 + Vector.length sagaEvents `shouldBe` 2 + Vector.length targetEvents `shouldBe` 2 + + it "runs no-advance and silent unconditional effects without accepted-only effects" $ \(_storeHandle, StoreRunner runner) -> do + let noAdvanceSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + silentSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2) + noAdvanceTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid + silentTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2 + acceptedOnlyTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid3 + noAdvancePlan = + Reaction.NoAdvance + [ Reaction.FollowSchedule Reaction.Once noAdvanceTimer, + Reaction.FollowDispatch (PMCommand (stream "reaction-target:no-advance") (Add 1)) + ] + silentPlan = + Reaction.AdvanceReaction + NoOpSilently + [ Reaction.FollowSchedule Reaction.Once silentTimer, + Reaction.FollowDispatch (PMCommand (stream "reaction-target:silent") (Add 2)) + ] + [ Reaction.FollowSchedule Reaction.Once acceptedOnlyTimer, + Reaction.FollowDispatch (PMCommand (stream "reaction-target:accepted-only") (Add 3)) + ] + Right (Right noAdvance) <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager noAdvanceSource ("no-advance", noAdvancePlan) + noAdvance ^. #managerResult `shouldBe` Reaction.ReactionNotAdvanced + noAdvance ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0 + Right noSaga <- runner $ Store.getStream (StreamName "reaction-saga:no-advance") + noSaga `shouldBe` Nothing + Right (Right silent) <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions silentReactionManager silentSource ("silent", silentPlan) + silent ^. #managerResult `shouldSatisfy` \case + Reaction.ReactionEvaluated DomainCommandOutcome {decision = DomainNoOp "edge-1: already complete"} -> True + _ -> False + silent ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0 + runner (lookupTimer (acceptedOnlyTimer ^. #timerId)) `shouldReturn` Right Nothing + Right acceptedOnlyEvents <- runner $ Store.readStreamForward (StreamName "reaction-target:accepted-only") (StreamVersion 0) 10 + acceptedOnlyEvents `shouldBe` Vector.empty + + it "retries missing same-target dispatches after a later command commits" $ \(_storeHandle, StoreRunner runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + target = stream "reaction-strict-target:order" :: Stream FeasibilityGateCommand + committedTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2 + plan = + Reaction.AdvanceReaction + (Add 1) + [ Reaction.FollowSchedule Reaction.Once committedTimer, + Reaction.FollowDispatch (PMCommand target (TryAccept 7)), + Reaction.FollowDispatch (PMCommand target OpenGate) + ] + [] + input = ("partial", plan) + Right (Right first) <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions strictTargetReactionManager sourceEvent input + first ^. #commandResults `shouldSatisfy` \case + [PMCommandFailed _ CommandRejected, PMCommandAppended {}] -> True + _ -> False + first ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0 + timerAfterTargetFailure <- runner (lookupTimer (committedTimer ^. #timerId)) + timerAfterTargetFailure `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Scheduled + _ -> False + Right (Right replayed) <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions strictTargetReactionManager sourceEvent input + replayed ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended {}, PMCommandDuplicate {}] -> True + _ -> False + replayed ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 0 0 0 + Right events <- runner $ Store.readStreamForward (StreamName "reaction-strict-target:order") (StreamVersion 0) 10 + traverse (decodeRecorded feasibilityGateCodec) (Vector.toList events) + `shouldBe` Right [GateOpened, GateAccepted 7] + + it "reconciles a concurrent target loser that rehydrates to a silent result" $ \(_storeHandle, StoreRunner runner) -> do + arrivals <- newMVar (0 :: Int) + release <- newEmptyMVar + firstResult <- newEmptyMVar + secondResult <- newEmptyMVar + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 3) + target = stream "reaction-race-target" :: Stream CounterCommand + plan = Reaction.NoAdvance [Reaction.FollowDispatch (PMCommand target (Add 3))] + input = ("race", plan) + awaitPeer = do + arrived <- modifyMVar arrivals $ \count -> + let next = count + 1 + in pure (next, next) + when (arrived == 2) (putMVar release ()) + readMVar release + options = defaultRunCommandOptions & #beforeAppend .~ awaitPeer & #retryBackoffMicros .~ 0 + runOne destination = + runner (Reaction.runReactiveProcessManagerOnce options retryTargetReactionManager sourceEvent input) + >>= putMVar destination + _ <- forkIO (runOne firstResult) + _ <- forkIO (runOne secondResult) + outcomes <- traverse takeMVar [firstResult, secondResult] + let successful = [result | Right (Right result) <- outcomes] + results = [commandResults | Reaction.ReactiveProcessManagerResult {commandResults} <- successful] + Prelude.length results `shouldBe` 2 + map (^. #timerEffects) successful `shouldBe` Prelude.replicate 2 (Reaction.ReactionTimerEffects 0 0 0) + results `shouldSatisfy` \observed -> + Prelude.length [() | [PMCommandAppended {}] <- observed] == 1 + && Prelude.length [() | [PMCommandDuplicate {}] <- observed] == 1 + + it "preserves timer statement order, Once payloads, and later-source Rearm updates" $ \(_storeHandle, StoreRunner runner) -> do + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2) + orderedId = TimerId sampleUuid + onceId = TimerId sampleUuid2 + rearmId = TimerId sampleUuid3 + reverseOrderId = TimerId (UUID.fromWords 0 0 0 104) + original id = counterTimerRequest & #timerId .~ id & #fireAt .~ dueTimerTime & #payload .~ object ["version" Aeson..= (1 :: Int)] + changed id = original id & #fireAt .~ addUTCTime 60 dueTimerTime & #payload .~ object ["version" Aeson..= (2 :: Int)] + runPlan source correlation followUps = + runner $ + Reaction.runReactiveProcessManagerOnce + defaultRunCommandOptions + counterReactionManager + source + (correlation, Reaction.NoAdvance followUps) + Right () <- runner $ Store.runTransaction (scheduleTimerTx (original orderedId)) + Right (Right ordered) <- + runPlan + sourceA + "ordered" + [Reaction.FollowSchedule Reaction.Rearm (changed orderedId), Reaction.FollowCancel orderedId] + ordered ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1 + orderedTimer <- runner (lookupTimer orderedId) + orderedTimer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Timer.Cancelled + _ -> False + Right () <- runner $ Store.runTransaction (scheduleTimerTx (original reverseOrderId)) + Right (Right reverseOrdered) <- + runPlan + sourceA + "reverse-ordered" + [Reaction.FollowCancel reverseOrderId, Reaction.FollowSchedule Reaction.Rearm (changed reverseOrderId)] + reverseOrdered ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1 + reverseTimer <- runner (lookupTimer reverseOrderId) + reverseTimer `shouldSatisfy` \case + Right (Just row) -> row ^. #status == Timer.Cancelled && row ^. #payload == object ["version" Aeson..= (1 :: Int)] + _ -> False + Right (Right _) <- runPlan sourceA "once-a" [Reaction.FollowSchedule Reaction.Once (original onceId)] + Right (Right _) <- runPlan sourceB "once-b" [Reaction.FollowSchedule Reaction.Once (changed onceId)] + onceTimer <- runner (lookupTimer onceId) + onceTimer `shouldSatisfy` \case + Right (Just row) -> row ^. #fireAt == dueTimerTime && row ^. #payload == object ["version" Aeson..= (1 :: Int)] + _ -> False + Right (Right _) <- runPlan sourceA "rearm-a" [Reaction.FollowSchedule Reaction.Rearm (original rearmId)] + Right (Right _) <- runPlan sourceB "rearm-b" [Reaction.FollowSchedule Reaction.Rearm (changed rearmId)] + rearmedTimer <- runner (lookupTimer rearmId) + rearmedTimer `shouldSatisfy` \case + Right (Just row) -> row ^. #fireAt == addUTCTime 60 dueTimerTime && row ^. #payload == object ["version" Aeson..= (2 :: Int)] + _ -> False + + it "rolls back saga and earlier timer writes when later timer SQL fails" $ \(_storeHandle, StoreRunner runner) -> do + Right () <- runner $ Store.runTransaction (Tx.sql reactionTimerFailureTriggerSql) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 4) + firstTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2 & #processManagerName .~ "reaction-ok" + failingTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid3 & #processManagerName .~ "reaction-fail" + plan = + Reaction.AdvanceReaction + (Add 4) + [ Reaction.FollowSchedule Reaction.Rearm firstTimer, + Reaction.FollowSchedule Reaction.Rearm failingTimer + ] + [] + outcome <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent ("timer-failure", plan) + outcome `shouldSatisfy` \case + Right (Left (Reaction.ReactionCommandFailed (StoreFailed _))) -> True + _ -> False + Right sagaEvents <- runner $ Store.readStreamForward (StreamName "reaction-saga:timer-failure") (StreamVersion 0) 10 + sagaEvents `shouldBe` Vector.empty + runner (lookupTimer (firstTimer ^. #timerId)) `shouldReturn` Right Nothing + runner (lookupTimer (failingTimer ^. #timerId)) `shouldReturn` Right Nothing + + it "rejects undecodable, foreign-stream, and wrong-target identity collisions" $ \(storeHandle, StoreRunner runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + correlationId = "collision" + managerId = deterministicCommandId "counter-reaction" correlationId (sourceEvent ^. #eventId) (-1) + sagaName = StreamName "reaction-saga:collision" + simplePlan = Reaction.AdvanceReaction (Add 1) [] [] + foreignEvent <- shouldBeRight (encodeForAppend feasibilityGateCodec GateOpened) + Right _ <- runner $ Store.appendToStream sagaName NoStream [foreignEvent & #eventId ?~ managerId] + undecodable <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent (correlationId, simplePlan) + undecodable `shouldBe` Right (Left (Reaction.ReactionWitnessUndecodable sagaName managerId)) + + let otherSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2) + otherCorrelation = "wrong-stream" + wrongManagerId = deterministicCommandId "counter-reaction" otherCorrelation (otherSource ^. #eventId) (-1) + appendCounterEventWithId storeHandle (StreamName "other-saga") wrongManagerId (CounterAdded 2) + wrongStream <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager otherSource (otherCorrelation, simplePlan) + wrongStream `shouldSatisfy` \case + Right (Left (Reaction.ReactionCommandFailed (StoreFailed _))) -> True + _ -> False + + let targetSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 3) + targetName = StreamName "reaction-target:collision" + targetId = Reaction.deterministicReactionCommandId "counter-reaction" "target-collision" (targetSource ^. #eventId) targetName 0 + targetPlan = Reaction.NoAdvance [Reaction.FollowDispatch (PMCommand (stream "reaction-target:collision") (Add 3))] + appendCounterEventWithId storeHandle (StreamName "other-target") targetId (CounterAdded 3) + Right (Right targetCollision) <- + runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager targetSource ("target-collision", targetPlan) + targetCollision ^. #commandResults `shouldSatisfy` \case + [PMCommandFailed observed (StoreFailed _)] -> observed == targetName + _ -> False + + it "pages accepted witnesses at 256, 1024, and 4096 event history depths" $ \(_storeHandle, StoreRunner runner) -> + forM_ [256, 1024, 4096] $ \depth -> do + let sourceId = EventId (UUID.fromWords 0 0 279 (fromIntegral depth)) + sourceEvent = recordedFromEventId sourceId (CounterAdded depth) + correlationId = "paged-witness-" <> Text.pack (show depth) + sagaName = StreamName ("reaction-saga:" <> correlationId) + managerId = deterministicCommandId "counter-reaction" correlationId sourceId (-1) + encoded <- traverse (shouldBeRight . encodeForAppend counterCodec . CounterAdded) [1 .. depth] + let withIds = + Prelude.zipWith + (\eventIndex event -> if eventIndex == depth - 1 then event & #eventId ?~ managerId else event) + [0 ..] + encoded + Right _ <- runner $ Store.appendToStream sagaName NoStream withIds + recovered <- + runner $ + Reaction.runReactiveProcessManagerOnce + defaultRunCommandOptions + counterReactionManager + sourceEvent + (correlationId, Reaction.AdvanceReaction (Add 1) [] []) + recovered `shouldSatisfy` \case + Right (Right result) -> case result ^. #managerResult of + Reaction.ReactionDuplicate duplicateId -> duplicateId == managerId + _ -> False + _ -> False + + it "runs the public-only handwritten reported and acknowledged example" $ \(_storeHandle, StoreRunner runner) -> do + let manager = ReactionExample.exampleReactionManager dueTimerTime + reportedSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + acknowledgedSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2) + correlationId = "incident-279" + Right (Right reported) <- + runner $ + Reaction.runReactiveProcessManagerOnce + defaultRunCommandOptions + manager + reportedSource + (ReactionExample.IncidentReported correlationId ReactionExample.Urgent) + reported ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 2 0 + reported ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended result] -> result ^. #eventsAppended == 1 + _ -> False + reminder <- runner (lookupTimer ReactionExample.exampleReminderTimerId) + escalation <- runner (lookupTimer ReactionExample.exampleEscalationTimerId) + reminder `shouldSatisfy` \case + Right (Just row) -> row ^. #fireAt == addUTCTime 300 dueTimerTime + _ -> False + escalation `shouldSatisfy` \case + Right (Just row) -> row ^. #fireAt == addUTCTime 900 dueTimerTime + _ -> False + Right (Right routine) <- + runner $ + Reaction.runReactiveProcessManagerOnce + defaultRunCommandOptions + manager + acknowledgedSource + (ReactionExample.IncidentReported "routine-279" ReactionExample.Routine) + routine ^. #managerResult `shouldBe` Reaction.ReactionNotAdvanced + routine ^. #commandResults `shouldBe` [] + Right routineSaga <- runner $ Store.getStream (StreamName "incident-reaction-saga:routine-279") + routineSaga `shouldBe` Nothing + let target = stream ("incident-reaction-target:" <> correlationId) + Right (Just firedReminder) <- + runner $ + runTimerWorker Nothing (addUTCTime 300 dueTimerTime) $ \_ -> do + late <- + runCommand + defaultRunCommandOptions + ReactionExample.exampleTargetEventStream + target + ReactionExample.ApplyLateTimeout + pure $ case late of + Right result | result ^. #eventsAppended == 0 -> Just (EventId sampleUuid3) + _ -> Nothing + firedReminder ^. #timerId `shouldBe` ReactionExample.exampleReminderTimerId + Right (Right acknowledged) <- + runner $ + Reaction.runReactiveProcessManagerOnce + defaultRunCommandOptions + manager + acknowledgedSource + (ReactionExample.IncidentAcknowledged correlationId) + acknowledged ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1 + runner (runTimerWorker Nothing (addUTCTime 300 dueTimerTime) (\_ -> error "fired reminder redelivered")) + `shouldReturn` Right Nothing + + it "worker finalizes each success and duplicate exactly once" $ \(_storeHandle, StoreRunner runner) -> do + decisions <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + target = stream "reaction-worker-target:ok" :: Stream CounterCommand + plan = Reaction.AdvanceReaction (Add 2) [] [Reaction.FollowDispatch (PMCommand target (Add 2))] + message = (sourceEvent, ("worker-ok", plan)) + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorker + defaultRunCommandOptions + counterReactionManager + (inMemoryAdapter decisions [message, message]) + Just + readIORef decisions `shouldReturn` [AckOk, AckOk] + Right targetEvents <- runner $ Store.readStreamForward (StreamName "reaction-worker-target:ok") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "worker applies target rejection policy with the overall dispatch index" $ \(_storeHandle, StoreRunner runner) -> do + decisions <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + target = stream "reaction-worker-strict:rejected" :: Stream FeasibilityGateCommand + plan = Reaction.AdvanceReaction (Add 1) [] [Reaction.FollowDispatch (PMCommand target (TryAccept 7))] + message = (sourceEvent, ("worker-rejected", plan)) + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorkerWith + workerOptions + defaultRunCommandOptions + strictTargetReactionManager + (inMemoryAdapter decisions [message]) + Just + readIORef decisions `shouldReturn` [AckOk] + Right deadLetters <- runner (listDispatchDeadLetters "strict-target-reaction") + deadLetters `shouldSatisfy` \case + [row] -> row ^. #emitIndex == 0 && row ^. #targetStreamName == StreamName "reaction-worker-strict:rejected" + _ -> False + + it "worker handles typed silence as a successful delivery" $ \(_storeHandle, StoreRunner runner) -> do + silentDecisions <- newIORef [] + let silentSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + silentPlan = Reaction.AdvanceReaction NoOpSilently [] [] + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorker + defaultRunCommandOptions + silentReactionManager + (inMemoryAdapter silentDecisions [(silentSource, ("worker-silent", silentPlan))]) + Just + readIORef silentDecisions `shouldReturn` [AckOk] + + it "worker records manager failures at index minus one" $ \(_storeHandle, StoreRunner runner) -> do + managerFailureDecisions <- newIORef [] + let failedSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2) + failedPlan = Reaction.AdvanceReaction (Add 2) [] [] + rejectingHandler = + DomainCommandHandler + { eventStream = rejectingEventStream, + classifySilent = \_ -> error "rejecting reaction handler selected a silent edge" + } + rejectingManager = + Reaction.ReactiveProcessManager + "counter-reaction" + Prelude.fst + rejectingHandler + (\correlationId -> stream ("reaction-saga:" <> correlationId)) + counterEventStream + (const []) + Prelude.snd + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorkerWith + workerOptions + defaultRunCommandOptions + rejectingManager + (inMemoryAdapter managerFailureDecisions [(failedSource, ("worker-manager-failure", failedPlan))]) + Just + readIORef managerFailureDecisions `shouldReturn` [AckOk] + Right deadLetters <- runner (listDispatchDeadLetters "counter-reaction") + deadLetters `shouldSatisfy` \case + [row] -> row ^. #emitIndex == (-1) && row ^. #targetStreamName == StreamName "reaction-saga:worker-manager-failure" + _ -> False + + it "worker uses bounded witness reasons and poison callbacks" $ \(_storeHandle, StoreRunner runner) -> do + witnessDecisions <- newIORef [] + poisonDecisions <- newIORef [] + poisoned <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + correlationId = "worker-witness" + managerId = deterministicCommandId "counter-reaction" correlationId (sourceEvent ^. #eventId) (-1) + plan = Reaction.AdvanceReaction (Add 1) [] [] + foreignEvent <- shouldBeRight (encodeForAppend feasibilityGateCodec GateOpened) + Right _ <- runner $ Store.appendToStream (StreamName "reaction-saga:worker-witness") NoStream [foreignEvent & #eventId ?~ managerId] + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorker + defaultRunCommandOptions + counterReactionManager + (inMemoryAdapter witnessDecisions [(sourceEvent, (correlationId, plan))]) + Just + readIORef witnessDecisions + `shouldReturn` [AckHalt (HaltFatal "process-reaction-witness-undecodable")] + let poisonOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' poisoned (<> [env ^. #payload]))) + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorkerWith + poisonOptions + defaultRunCommandOptions + counterReactionManager + (inMemoryAdapter poisonDecisions ["not-a-reaction" :: Text]) + (const Nothing) + readIORef poisonDecisions + `shouldReturn` [AckDeadLetter (InvalidPayload "process-reaction-worker-decode-failed")] + readIORef poisoned `shouldReturn` ["not-a-reaction"] + + it "worker lets asynchronous cancellation escape without acknowledging" $ \(_storeHandle, StoreRunner runner) -> do + decisions <- newIORef [] + let workerOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonSkip (\_ -> liftIO (throwIO ThreadKilled)) + cancelled <- + try @AsyncException $ + runner $ + Reaction.runReactiveProcessManagerWorkerWith + workerOptions + defaultRunCommandOptions + counterReactionManager + (inMemoryAdapter decisions ["cancel" :: Text]) + (const Nothing) + cancelled `shouldBe` Left ThreadKilled + readIORef decisions `shouldReturn` [] + + it "scales worker fan-out across 8, 32, and 128 same and distinct targets" $ \(_storeHandle, StoreRunner runner) -> + forM_ [8, 32, 128] $ \fanOut -> + forM_ [("same", True), ("distinct", False)] $ \(flavor, sameTarget) -> do + decisions <- newIORef [] + let sourceId = + EventId + ( UUID.fromWords + 0 + 0 + (if sameTarget then 279 else 280) + (fromIntegral fanOut) + ) + sourceEvent = recordedFromEventId sourceId (CounterAdded fanOut) + correlationId = "fanout-" <> flavor <> "-" <> Text.pack (show fanOut) + targetName targetIndex = + if sameTarget + then "reaction-fanout:" <> flavor <> ":" <> Text.pack (show fanOut) + else "reaction-fanout:" <> flavor <> ":" <> Text.pack (show fanOut) <> ":" <> Text.pack (show targetIndex) + commands = + [ Reaction.FollowDispatch (PMCommand (stream (targetName targetIndex)) (Add targetIndex)) + | targetIndex <- [1 .. fanOut] + ] + plan = Reaction.AdvanceReaction (Add fanOut) [] commands + message = (sourceEvent, (correlationId, plan)) + Right () <- + runner $ + Reaction.runReactiveProcessManagerWorker + defaultRunCommandOptions + counterReactionManager + (inMemoryAdapter decisions [message]) + Just + readIORef decisions `shouldReturn` [AckOk] + Right sagaEvents <- + runner $ + Store.readStreamForward + (StreamName ("reaction-saga:" <> correlationId)) + (StreamVersion 0) + 10 + Vector.length sagaEvents `shouldBe` 2 + persistedCounts <- + if sameTarget + then do + Right events <- runner $ Store.readStreamForward (StreamName (targetName 1)) (StreamVersion 0) (fromIntegral fanOut + 1) + pure [Vector.length events] + else forM [1 .. fanOut] $ \targetIndex -> do + Right events <- runner $ Store.readStreamForward (StreamName (targetName targetIndex)) (StreamVersion 0) 2 + pure (Vector.length events) + Prelude.sum persistedCounts `shouldBe` fanOut + + describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do + it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 1 + other -> expectationFailure ("expected appended manager state, got " <> show other) + case pmResult ^. #commandResults of + [PMCommandAppended commandResult] -> + commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected one emitted command, got " <> show other) + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "counter-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + case pmResult ^. #managerResult of + PMStateAppended managerResult -> do + managerResult ^. #streamVersion `shouldBe` StreamVersion 0 + managerResult ^. #eventsAppended `shouldBe` 0 + other -> expectationFailure ("expected no-op manager state, got " <> show other) + pmResult ^. #commandResults `shouldBe` [] + pmResult ^. #timersScheduled `shouldBe` 1 + other -> expectationFailure ("expected process-manager success, got " <> show other) + dueCount <- + _runner $ + countDueTimers dueTimerTime + dueCount `shouldBe` Right 1 + timer <- + _runner $ + claimDueTimer dueTimerTime + case timer of + Right (Just row) -> do + row ^. #processManagerName `shouldBe` "timer-only-pm" + row ^. #correlationId `shouldBe` "order-1" + other -> expectationFailure ("expected scheduled timer row, got " <> show other) + + it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + duplicate <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4) + case duplicate of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate {} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate {}] -> True + _ -> False + other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 1 + Vector.length targetEvents `shouldBe` 1 + + it "bridges a pre-UTF-8 process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + correlationId = "\x4E2D\x6587-42" + managerStreamName = StreamName "pm:counter-unicode" + targetStreamName = StreamName "counter-target-unicode" + legacyManagerId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) (-1) + legacyCommandId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) 0 + appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 9) + appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9) + Right (Right pmResult) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions unicodeCounterProcessManager sourceEvent (CounterAdded 9) + Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10 + Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 + ( pmResult ^. #managerResult, + pmResult ^. #commandResults, + Vector.length managerEvents, + Vector.length targetEvents + ) + `shouldBe` ( PMStateDuplicate legacyManagerId, + [PMCommandDuplicate legacyCommandId], + 1, + 1 + ) + + it "bridges a pre-UTF-8 domain process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + correlationId = "\x4E2D\x6587-9" + managerStreamName = StreamName ("domain-pm:" <> correlationId) + targetStreamName = StreamName ("domain-pm-target:" <> correlationId <> ":0") + legacyManagerId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) (-1) + legacyCommandId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) 0 + input = DomainDispatchInput correlationId [CoordinatorAccept 9] + appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 1) + appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9) + Right (Right pmResult) <- + _runner $ + runDomainProcessManagerOnce defaultRunCommandOptions domainProcessManager sourceEvent input + Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10 + Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 + ( pmResult ^. #managerResult, + pmResult ^. #commandResults, + Vector.length managerEvents, + Vector.length targetEvents + ) + `shouldBe` ( PMStateDuplicate legacyManagerId, + [DomainPMCommandDuplicate legacyCommandId], + 1, + 1 + ) + + it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-fresh" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7) + Right listed <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length listed `shouldBe` 1 + + Right firstPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + firstPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedFresh + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + + Right secondPass <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + secondPass + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` (1, 1) + Right retained <- _runner (listSubscriptionDeadLetters subName 0) + Vector.length retained `shouldBe` 1 + + it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do + let subName = SubscriptionName "counter-pm-replay-duplicate" + replayHandler recorded = + case decodeRecorded counterCodec recorded of + Left err -> pure (Left (Text.pack (show err))) + Right input -> do + outcome <- + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + recorded + input + pure $ + case outcome of + Left err -> Left (Text.pack (show err)) + Right result -> Right (classifyProcessManagerReplay result) + source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8) + Right (Right _) <- + _runner $ + runProcessManagerOnce + defaultRunCommandOptions + counterProcessManager + source + (CounterAdded 8) + countsBefore <- processManagerReplayCounts _storeHandle + + Right outcomes <- + _runner $ + replaySubscriptionDeadLetters subName 0 replayHandler + outcomes + `shouldBe` [ ReplayOutcome + { replayGlobalPosition = source ^. #globalPosition, + replayEventId = source ^. #eventId, + replayResult = ReplayedDuplicate + } + ] + processManagerReplayCounts _storeHandle `shouldReturn` countsBefore + + it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6) + fulfillmentManager = + workflowProcessManager + "fulfillment-pm" + "pm:fulfillment" + "fulfillment-target-order-1" + billingManager = + workflowProcessManager + "billing-pm" + "pm:billing" + "billing-target-order-1" + fulfillmentResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6) + billingResult <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6) + assertWorkflowProcessManagerAppended fulfillmentResult + assertWorkflowProcessManagerAppended billingResult + + Right fulfillmentManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10 + Right billingManagerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10 + Right fulfillmentTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10 + Right billingTargetEvents <- + _runner $ + Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10 + Vector.length fulfillmentManagerEvents `shouldBe` 1 + Vector.length billingManagerEvents `shouldBe` 1 + Vector.length fulfillmentTargetEvents `shouldBe` 1 + Vector.length billingTargetEvents `shouldBe` 1 + + Right fulfillmentCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10 + Right billingCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10 + Right sharedPmCategoryEvents <- + _runner $ + Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10 + Right sharedPmNamespaceEvents <- + _runner $ + Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10 + Vector.length fulfillmentCategoryEvents `shouldBe` 1 + Vector.length billingCategoryEvents `shouldBe` 1 + sharedPmCategoryEvents `shouldBe` Vector.empty + sharedPmNamespaceEvents `shouldBe` Vector.empty + + it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk] + + it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + Right () <- + _runner $ + runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 0 + Vector.length managerEvents `shouldBe` 1 + + it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(first, CounterAdded 9), (second, CounterAdded 1)] + adapter = inMemoryAdapter decisionsRef messages + policyPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectNineEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedDeadLetter + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherProcessManager + row ^. #correlationId `shouldBe` "order-1" + row ^. #sourceEventId `shouldBe` EventId sampleUuid + row ^. #emitIndex `shouldBe` 0 + row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10 + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + Vector.length managerEvents `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = + defaultWorkerOptions + & #rejectedCommandPolicy + .~ RejectedSkip + & #metrics + ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + deadLetters `shouldBe` [] + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)] + rejectingManager = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { eventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + case deadLetters of + [row] -> do + row ^. #emitIndex `shouldBe` (-1) + row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one manager-state dead letter, got " <> show other) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10 + managerEvents `shouldBe` Vector.empty + + it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)] + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + readIORef decisionsRef `shouldReturn` [AckOk, AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm") + Prelude.length deadLetters `shouldBe` 1 + + it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + messages = [(sourceEvent, CounterAdded 9)] + adapter = inMemoryAdapter decisionsRef messages + rejectingPm = + (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent) + { targetEventStream = rejectingEventStream + } + workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics + Right () <- + _runner $ + runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do + isRejectionClass CommandRejected `shouldBe` True + isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True + isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False + ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom")) + `shouldBe` AckRetry (RetryDelay 5) + -- kiroku-store 0.8.0.0 types class-40 rollbacks separately from + -- UnexpectedServerError. The transaction rolled back completely and + -- nothing was committed, so the source event retries rather than halting + -- the subscription; every other server code still halts. + ackForCommandError + (RetryDelay 5) + (StoreFailed (Store.TransientTransactionFailure "40001" "could not serialize access")) + `shouldBe` AckRetry (RetryDelay 5) + ackForCommandError + (RetryDelay 5) + (StoreFailed (Store.TransientTransactionFailure "40P01" "deadlock detected")) + `shouldBe` AckRetry (RetryDelay 5) + ackForCommandError (RetryDelay 5) (StoreFailed (Store.UnexpectedServerError "XX000" "boom")) + `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case + AckHalt (HaltFatal _) -> True + _ -> False + + it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do + let badMessages = ["not-decodable" :: Text] + defaultDecisions <- newIORef [] + Right () <- + _runner $ + runProcessManagerWorker + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter defaultDecisions badMessages) + (const Nothing) + defaultObserved <- readIORef defaultDecisions + defaultObserved `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + skippedRef <- newIORef [] + skipDecisions <- newIORef [] + let skipOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + skipOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter skipDecisions badMessages) + (const Nothing) + readIORef skipDecisions `shouldReturn` [AckOk] + readIORef skippedRef `shouldReturn` badMessages + + deadLetterDecisions <- newIORef [] + deadLetterRef <- newIORef [] + let deadLetterOptions = + defaultWorkerOptions + & #poisonPolicy + .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload]))) + Right () <- + _runner $ + runProcessManagerWorkerWith + deadLetterOptions + defaultRunCommandOptions + counterProcessManager + (inMemoryAdapter deadLetterDecisions badMessages) + (const Nothing) + deadLetterObserved <- readIORef deadLetterDecisions + deadLetterObserved `shouldSatisfy` \case + [AckDeadLetter (InvalidPayload _)] -> True + _ -> False + readIORef deadLetterRef `shouldReturn` badMessages + + it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "counter-target-order-1" + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandDuplicate duplicateId] -> duplicateId == commandId + _ -> False + other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1) + managerStreamName = StreamName "pm:counter-order-1" + insertConcurrentManager = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentManager + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9) + case result of + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateDuplicate duplicateId -> duplicateId == managerId + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended {}] -> True + _ -> False + other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other) + + describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do + it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-mismatch" + ourId = EventId sampleUuid + otherId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just otherId))) + outcome `shouldBe` Right False + + it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-target" + otherStreamName = StreamName "duplicate-confirmation-other" + ourId = EventId sampleUuid + targetEventId = EventId sampleUuid2 + appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1) + appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + outcome `shouldBe` Right False + + it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-present" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + matchingOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent (Just ourId))) + missingDetailOutcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.DuplicateEvent Nothing)) + matchingOutcome `shouldBe` Right True + missingDetailOutcome `shouldBe` Right True + + it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do + let targetStreamName = StreamName "duplicate-confirmation-non-duplicate" + ourId = EventId sampleUuid + appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1) + outcome <- + _runner $ + confirmBenignDuplicate + targetStreamName + ourId + (StoreFailed (Store.ConnectionLost "boom")) + outcome `shouldBe` Right False + + describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do + it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do + -- Two distinct source events, both correlating to "order-1", drive the one + -- manager instance to manager-stream version 2, which Every 2 snapshots. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + Right managerEvents <- + _runner $ + Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10 + Vector.length managerEvents `shouldBe` 2 + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + + it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do + -- After the threshold snapshot exists, a third reaction should land on top of + -- the snapshot at version 3 rather than replaying from version 0. + let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2) + sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3) + sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2) + Right (Right _) <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3) + -- Confirm the snapshot is present before the tail-replay reaction. + Right snapshotVersion <- + _runner $ + Store.runTransaction $ + Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt + snapshotVersion `shouldBe` Just (StreamVersion 2) + result <- + _runner $ + runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4) + case result of + Right (Right pmResult) -> + case pmResult ^. #managerResult of + PMStateAppended managerResult -> + managerResult ^. #streamVersion `shouldBe` StreamVersion 3 + other -> expectationFailure ("expected appended manager state, got " <> show other) + other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other) + + describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do + it "RouterSelection validates positive runtime invariants" $ \(_storeHandle, StoreRunner _runner) -> do + mkRecipientLimit 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False + mkSelectionVersion 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False + limit <- shouldBeRight (mkRecipientLimit 2) + selectionVersion <- shouldBeRight (mkSelectionVersion 3) + recipientLimitValue limit `shouldBe` 2 + selectionVersionValue selectionVersion `shouldBe` 3 + + it "RouterSelection sorts, deduplicates, caps, and rejects conflicts before dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + limit <- shouldBeRight (mkRecipientLimit 2) + one <- shouldBeRight (mkRecipientLimit 1) + let targetA = PMCommand {target = stream "selection-a", command = Add 1} + targetB = PMCommand {target = stream "selection-b", command = Add 1} + targetBConflict = PMCommand {target = stream "selection-b", command = Add 2} + normalizeRecipients limit [targetB, targetA, targetB] + `shouldBe` Right [targetA, targetB] + normalizeRecipients limit [targetB, targetBConflict, targetA] + `shouldBe` Left (SelectionConflictingCommands (StreamName "selection-b")) + normalizeRecipients one [targetB, targetA, targetB] + `shouldBe` Left (SelectionRecipientOverflow one 2) + normalizeRecipients limit [targetB, targetA] + `shouldBe` Right [targetA, targetB] + + it "RouterSelection exposes stable public dead-letter code, detail, and rendering" $ \(_storeHandle, StoreRunner _runner) -> do + contract <- testSelectionContract EmptyDeadLetter FailureDeadLetter 4 + recipientLimit <- shouldBeRight (mkRecipientLimit 4) + let failures = + [ (SelectionQueryFailed "secret backend detail", "keiro.router.selection.query_failed"), + (SelectionEvaluationFailed "secret payload", "keiro.router.selection.evaluation_failed"), + (SelectionConflictingCommands (StreamName "hospital-1"), "keiro.router.selection.target_conflict"), + (SelectionRecipientOverflow recipientLimit 5, "keiro.router.selection.recipient_overflow") + ] + assertReason expectedCode reason = do + deadLetterCodeText (deadLetterReasonCode reason) `shouldBe` expectedCode + deadLetterReasonDetail reason `shouldSatisfy` maybe False (not . Text.null) + renderDeadLetterReason reason `shouldSatisfy` Text.isPrefixOf (expectedCode <> ": ") + assertReason "keiro.router.selection.empty" (emptySelectionDeadLetterReason contract) + for_ failures $ \(failure, expectedCode) -> do + let reason = selectionFailureDeadLetterReason contract failure + assertReason expectedCode reason + renderDeadLetterReason reason `shouldNotSatisfy` Text.isInfixOf "secret" + + it "RouterSelection performs no target callback on conflict or overflow and dispatches exactly at the cap" $ \(_storeHandle, StoreRunner _runner) -> do + twoRecipientContract <- testSelectionContract EmptyAck FailureRetry 2 + oneRecipientContract <- testSelectionContract EmptyAck FailureRetry 1 + callbacks <- newIORef (0 :: Int) + let options = defaultRunCommandOptions & #beforeAppend .~ modifyIORef' callbacks (+ 1) + sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + targetA = PMCommand {target = stream "bounded-a", command = Add 1} + targetB = PMCommand {target = stream "bounded-b", command = Add 1} + targetBConflict = PMCommand {target = stream "bounded-b", command = Add 2} + Right conflict <- + _runner $ + runDeclarativeRouterOnce + options + (selectionRouter twoRecipientContract (pure (Right [targetB, targetBConflict, targetA]))) + sourceEvent + (RouteGroup "g1") + conflict `shouldBe` DeclarativeSelectionFailed (SelectionConflictingCommands (StreamName "bounded-b")) + readIORef callbacks `shouldReturn` 0 + Right overflow <- + _runner $ + runDeclarativeRouterOnce + options + (selectionRouter oneRecipientContract (pure (Right [targetB, targetA, targetB]))) + sourceEvent + (RouteGroup "g1") + overflow `shouldBe` DeclarativeSelectionFailed (SelectionRecipientOverflow (oneRecipientContract ^. #limit) 2) + readIORef callbacks `shouldReturn` 0 + Right atCap <- + _runner $ + runDeclarativeRouterOnce + options + (selectionRouter twoRecipientContract (pure (Right [targetB, targetA, targetB]))) + sourceEvent + (RouteGroup "g1") + atCap `shouldSatisfy` \case + DeclarativeSelectionDispatched (RouterResult results) -> length results == 2 && all isAppended results + _ -> False + readIORef callbacks `shouldReturn` 2 + + it "RouterSelection retains successful targets after a later target dispatch fails" $ \(_storeHandle, StoreRunner _runner) -> do + contract <- testSelectionContract EmptyAck FailureRetry 2 + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = + selectionRouter contract (pure (Right [PMCommand {target = stream "partial-a", command = Add 1}, PMCommand {target = stream "partial-b", command = Add 9}])) + & #targetEventStream + .~ rejectNineEventStream + Right result <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) + result `shouldSatisfy` \case + DeclarativeSelectionDispatched (RouterResult [first, second]) -> isAppended first && isFailed second + _ -> False + Right partialA <- _runner (Store.readStreamForward (StreamName "partial-a") (StreamVersion 0) 10) + Right partialB <- _runner (Store.readStreamForward (StreamName "partial-b") (StreamVersion 0) 10) + Vector.length partialA `shouldBe` 1 + Vector.length partialB `shouldBe` 0 + + it "RouterSelection preserves target-keyed stable union across result drift" $ \(_storeHandle, StoreRunner _runner) -> do + contract <- testSelectionContract EmptyAck FailureRetry 2 + attempts <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + selectAttempt _ = do + attempt <- liftIO (atomicModifyIORef' attempts (\value -> (value + 1, value))) + pure $ Right $ case attempt of + 0 -> commandsFor ["union-b", "union-a"] + _ -> commandsFor ["union-c", "union-a"] + commandsFor targetNames = [PMCommand {target = stream targetName, command = Add 1} | targetName <- targetNames] + router = (selectionRouter contract (pure (Right []))) {select = selectAttempt} + Right first <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) + Right second <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")) + first `shouldSatisfy` \case + DeclarativeSelectionDispatched (RouterResult results) -> all isAppended results + _ -> False + second `shouldSatisfy` \case + DeclarativeSelectionDispatched (RouterResult [unionA, unionC]) -> isDuplicate unionA && isAppended unionC + _ -> False + for_ ["union-a", "union-b", "union-c"] $ \targetName -> do + Right events <- _runner (Store.readStreamForward (StreamName targetName) (StreamVersion 0) 10) + Vector.length events `shouldBe` 1 + + it "RouterSelection worker lowers the complete empty and failure policy matrices" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + message = (sourceEvent, RouteGroup "g1") + runCase emptySelectionPolicy failureSelectionPolicy selected = do + contract <- testSelectionContract emptySelectionPolicy failureSelectionPolicy 2 + decisions <- newIORef [] + Right () <- + _runner $ + runDeclarativeRouterWorker + defaultRunCommandOptions + (selectionRouter contract (pure selected)) + (inMemoryAdapter decisions [message]) + Just + readIORef decisions + runCase EmptyAck FailureRetry (Right []) `shouldReturn` [AckOk] + runCase EmptyRetry FailureRetry (Right []) `shouldReturn` [AckRetry (RetryDelay 5)] + emptyDeadLetter <- runCase EmptyDeadLetter FailureRetry (Right []) + emptyDeadLetter `shouldSatisfy` \case + [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.empty" + _ -> False + emptyHalt <- runCase EmptyHalt FailureRetry (Right []) + emptyHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False + runCase EmptyAck FailureRetry (Left (SelectionQueryFailed "private")) `shouldReturn` [AckRetry (RetryDelay 5)] + failureDeadLetter <- runCase EmptyAck FailureDeadLetter (Left (SelectionEvaluationFailed "private")) + failureDeadLetter `shouldSatisfy` \case + [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.evaluation_failed" + _ -> False + failureHalt <- runCase EmptyAck FailureHalt (Left (SelectionQueryFailed "private")) + failureHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False + + it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do + let sourceEventId = EventId sampleUuid + colonLeft = + deterministicRouterCommandId + "router:a" + "key" + sourceEventId + (StreamName "target") + 0 + colonRight = + deterministicRouterCommandId + "router" + "a:key" + sourceEventId + (StreamName "target") + 0 + unicodeLeft = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x101')) + 0 + unicodeRight = + deterministicRouterCommandId + "router" + "key" + sourceEventId + (StreamName ("target-" <> Text.singleton '\x201')) + 0 + colonLeft `shouldNotBe` colonRight + unicodeLeft `shouldNotBe` unicodeRight + + it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs1 `shouldBe` 3 + rs1 `shouldSatisfy` all isAppended + -- Data-dependence is load-bearing: an unseeded group resolves to no + -- targets, so the count tracks the read model, not a fixed list. + Right (RouterResult rsEmpty) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group") + length rsEmpty `shouldBe` 0 + -- Each resolved target stream received exactly one command. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "router-target-a") insertRouterTargetStmt + Tx.statement ("g1", "router-target-b") insertRouterTargetStmt + Tx.statement ("g1", "router-target-c") insertRouterTargetStmt + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + Right (RouterResult rs1) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + rs1 `shouldSatisfy` all isAppended + Right (RouterResult rs2) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + length rs2 `shouldBe` 3 + rs2 `shouldSatisfy` all isDuplicate + -- Replay added nothing: each target stream still holds exactly one event. + Right targetA <- + _runner $ + Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10 + Right targetB <- + _runner $ + Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10 + Right targetC <- + _runner $ + Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10 + Vector.length targetA `shouldBe` 1 + Vector.length targetB `shouldBe` 1 + Vector.length targetC `shouldBe` 1 + + it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["swap-a"] + _ -> ["swap-b", "swap-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [swapB, swapA] -> isAppended swapB && isDuplicate swapA + _ -> False + Right swapAEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10 + Right swapBEvents <- + _runner $ + Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10 + Vector.length swapAEvents `shouldBe` 1 + Vector.length swapBEvents `shouldBe` 1 + + it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["growth-a", "growth-b"] + _ -> ["growth-a", "growth-c"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [growthA, growthC] -> isDuplicate growthA && isAppended growthC + _ -> False + Right growthAEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10 + Right growthBEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10 + Right growthCEvents <- + _runner $ + Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10 + Vector.length growthAEvents `shouldBe` 1 + Vector.length growthBEvents `shouldBe` 1 + Vector.length growthCEvents `shouldBe` 1 + + it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["order-a", "order-b"] + _ -> ["order-b", "order-a"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right orderAEvents <- + _runner $ + Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10 + Right orderBEvents <- + _runner $ + Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10 + Vector.length orderAEvents `shouldBe` 1 + Vector.length orderBEvents `shouldBe` 1 + + it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef $ \case + 0 -> ["drop-a", "drop-b"] + _ -> ["drop-b"] + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` \case + [dropB] -> isDuplicate dropB + _ -> False + -- Resolve is authoritative per attempt. Across redeliveries, the + -- dispatched set is the union of each attempt's resolved targets. + Right dropAEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10 + Right dropBEvents <- + _runner $ + Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10 + Vector.length dropAEvents `shouldBe` 1 + Vector.length dropBEvents `shouldBe` 1 + + it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do + attemptsRef <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + router = unstableRouter attemptsRef (const ["twin", "twin"]) + Right (RouterResult firstAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + firstAttempt `shouldSatisfy` all isAppended + Right twinEventsAfterFirstAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterFirstAttempt `shouldBe` 2 + Right (RouterResult secondAttempt) <- + _runner $ + runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1") + secondAttempt `shouldSatisfy` all isDuplicate + Right twinEventsAfterSecondAttempt <- + _runner $ + Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10 + Vector.length twinEventsAfterSecondAttempt `shouldBe` 2 + + it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- _runner $ + Store.runTransaction $ do + Tx.statement ("g1", "worker-a") insertRouterTargetStmt + Tx.statement ("g1", "worker-b") insertRouterTargetStmt + Tx.statement ("g2", "worker-c") insertRouterTargetStmt + decisionsRef <- newIORef [] + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = + [ (sourceEvent1, RouteGroup "g1"), + (sourceEvent2, RouteGroup "g2") + ] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions demoRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldBe` [AckOk, AckOk] + Right wa <- + _runner $ + Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10 + Right wb <- + _runner $ + Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10 + Right wc <- + _runner $ + Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10 + Vector.length wa `shouldBe` 1 + Vector.length wb `shouldBe` 1 + Vector.length wc `shouldBe` 1 + + it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")] + workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter + Right () <- + _runner $ + runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just + readIORef decisionsRef `shouldReturn` [AckOk] + Right deadLetters <- _runner (listDispatchDeadLetters "failing-router") + case deadLetters of + [row] -> do + row ^. #dispatcherKind `shouldBe` DispatcherRouter + row ^. #correlationId `shouldBe` "g1" + row ^. #targetStreamName `shouldBe` StreamName "failing-target" + row ^. #errorClass `shouldBe` "command_rejected" + other -> expectationFailure ("expected one router dead letter, got " <> show other) + + it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt) + decisionsRef <- newIORef [] + attemptsRef <- newIORef (0 :: Int) + let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1) + messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")] + adapter = inMemoryAdapter decisionsRef messages + flakyRouter :: + (IOE :> es, Store :> es, Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + flakyRouter = + Router + { name = "flaky-router", + key = \(RouteGroup g) -> g, + resolve = \(RouteGroup g) -> do + attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n))) + if attempt == 0 + then throwError (Store.ConnectionLost "injected") + else do + result <- runQuery Nothing routerTargetsReadModel g + pure $ case result of + Right targetIds -> + [ PMCommand {target = stream targetId, command = Add 1} + | targetId <- targetIds + ] + Left _ -> [], + targetEventStream = counterEventStream, + targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions flakyRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckRetry {}, AckOk] -> True + _ -> False + + it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do + decisionsRef <- newIORef [] + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + messages = [(sourceEvent, RouteGroup "g1")] + adapter = inMemoryAdapter decisionsRef messages + failingResolveRouter :: + (Error Store.StoreError :> es) => + Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es + failingResolveRouter = + Router + { name = "failing-resolve-router", + key = \(RouteGroup g) -> g, + resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom"), + targetEventStream = counterEventStream, + targetProjections = const [] + } + Right () <- + _runner $ + runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just + decisions <- readIORef decisionsRef + decisions `shouldSatisfy` \case + [AckHalt (HaltFatal _)] -> True + _ -> False + + it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt) + insertCount <- newIORef (0 :: Int) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + targetStreamName = StreamName "router-duplicate-target" + commandId = + deterministicRouterCommandId + "demo-router" + "g1" + (sourceEvent ^. #eventId) + targetStreamName + 0 + insertConcurrentTarget = do + callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n)) + when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1) + options = + defaultRunCommandOptions + & #beforeAppend + .~ insertConcurrentTarget + & #retryBackoffMicros + .~ 0 + result <- + _runner $ + runRouterOnce options demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` commandId + other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + Right () <- + _runner $ + Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt) + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0 + targetStreamName = StreamName "transition-target" + appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1) + result <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1") + case result of + Right (RouterResult [PMCommandDuplicate duplicateId]) -> + duplicateId `shouldBe` legacyId + other -> expectationFailure ("expected transition duplicate, got " <> show other) + Right targetEvents <- + _runner $ + Store.readStreamForward targetStreamName (StreamVersion 0) 10 + Vector.length targetEvents `shouldBe` 1 + + it "bridges a pre-UTF-8 positional router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do + Right () <- + _runner $ + initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable + let correlationId = "g-\x4E2D\x6587" + targetStreamName = StreamName "transition-unicode-target" + sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1) + legacyId = legacyDeterministicCommandId "demo-router" correlationId (sourceEvent ^. #eventId) 0 + Right () <- + _runner $ + Store.runTransaction (Tx.statement (correlationId, "transition-unicode-target") insertRouterTargetStmt) + appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 1) + Right (RouterResult results) <- + _runner $ + runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup correlationId) + Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 + (results, Vector.length targetEvents) + `shouldBe` ([PMCommandDuplicate legacyId], 1) + + it "bridges a pre-UTF-8 domain router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do + let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9) + correlationId = "\x4E2D\x6587-9" + targetStreamName = StreamName ("domain-router-target:" <> correlationId <> ":0") + legacyId = legacyDeterministicCommandId "domain-router" correlationId (sourceEvent ^. #eventId) 0 + input = DomainDispatchInput correlationId [CoordinatorAccept 9] + appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 9) + Right (DomainRouterResult results) <- + _runner $ + runDomainRouterOnce defaultRunCommandOptions domainRouter sourceEvent input + Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10 + (results, Vector.length targetEvents) + `shouldBe` ([DomainPMCommandDuplicate legacyId], 1) + + describe "Keiro.Timer foreground consumer" + $ around + ( \action -> + withFreshDatabase fixture $ \connection -> + Store.withStore (Store.defaultConnectionSettings connection) $ \firstStore -> + Store.withStore (Store.defaultConnectionSettings connection) $ \secondStore -> + action (firstStore, secondStore) + ) + $ do + it "preflights original work and invokes one callback for competing authorized resumes" $ \(firstStore, secondStore) -> do + let original = counterTimerRequest & #payload .~ object ["memorySpace" Aeson..= ("space-a" :: Text)] + tid = original ^. #timerId + owner = original ^. #processManagerName + reason = "deferred: interactive session required" + callbacks <- newIORef (0 :: Int) + let foreground store allowed available = do + Right _ <- Store.runStoreIO store recoverExpiredTimerResumes + Right inspected <- Store.runStoreIO store $ lookupTimerInspection tid + case inspected of + Just inspection + | inspection ^. #lastError == Just reason, + inspection ^. #timer . #payload == object ["memorySpace" Aeson..= ("space-a" :: Text)], + allowed, + available -> do + Right (Right claimed) <- Store.runStoreIO store $ claimDeadTimer (DeadTimerClaimRequest tid owner reason 3 60) + forM_ claimed $ \_ -> atomicModifyIORef' callbacks (\n -> (n + 1, ())) + pure claimed + _ -> pure Nothing + Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx original + Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid reason + Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt + -- Revocation after listing and repeated unavailable-session preflights. + Right (Right _) <- Store.runStoreIO firstStore $ findDeadTimers (DeadTimerFilter (Just owner) (ReasonExact reason)) (DeadTimerPageRequest 10 Nothing) + denied <- foreground firstStore False True + isNothing denied `shouldBe` True + forM_ [1 .. 3 :: Int] $ \_ -> do + unavailable <- foreground firstStore True False + isNothing unavailable `shouldBe` True + Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before + (a, b) <- timerRaceIO (foreground firstStore True True) (foreground secondStore True True) + length (catMaybes [a, b]) `shouldBe` 1 + readIORef callbacks `shouldReturn` 1 + -- Crash, deterministic expiry, and recovery keep interactive work parked. + Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx + Store.runStoreIO secondStore recoverExpiredTimerResumes `shouldReturn` Right 1 + Store.runStoreIO firstStore (runTimerWorker Nothing dueTimerTime (\_ -> error "interactive work dispatched in background")) `shouldReturn` Right Nothing + unavailable <- foreground firstStore True False + isNothing unavailable `shouldBe` True + Just next <- foreground secondStore True True + resumeClaimTimer next ^. #timerId `shouldBe` tid + resumeClaimTimer next ^. #attempts `shouldBe` 2 + -- A transient post-claim failure consumes the attempt and retains reason. + Store.runStoreIO secondStore (parkTimerResume next) `shouldReturn` Right True + Right (Just parked) <- Store.runStoreIO firstStore $ lookupTimerInspection tid + parked ^. #lastError `shouldBe` Just reason + parked ^. #timer . #attempts `shouldBe` 2 + -- Malformed work and ordinary dead letters are application refusals. + Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET payload = '{}'::jsonb" + malformed <- foreground firstStore True True + isNothing malformed `shouldBe` True + Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET last_error = 'ordinary dead letter'" + ordinary <- foreground firstStore True True + isNothing ordinary `shouldBe` True + readIORef callbacks `shouldReturn` 2 + + it "orders renewal and completion against recovery on independent stores" $ \(firstStore, secondStore) -> do + let tid = counterTimerRequest ^. #timerId + request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60 + Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx counterTimerRequest + Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid "deferred" + Right (Right (Just claim)) <- Store.runStoreIO firstStore $ claimDeadTimer request + (renewed, recovered) <- + timerRaceIO + (Store.runStoreIO firstStore $ renewTimerResume claim 60) + (Store.runStoreIO secondStore recoverExpiredTimerResumes) + renewed `shouldBe` Right (Right True) + recovered `shouldBe` Right 0 + Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx + (expiredRenewal, expiredRecovery) <- + timerRaceIO + (Store.runStoreIO firstStore $ renewTimerResume claim 60) + (Store.runStoreIO secondStore recoverExpiredTimerResumes) + expiredRenewal `shouldBe` Right (Right False) + expiredRecovery `shouldBe` Right 1 + Right (Right (Just replacement)) <- Store.runStoreIO firstStore $ claimDeadTimer request + Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt + forM_ [parkTimerResume claim, cancelTimerResume claim, completeTimerResume claim (EventId sampleUuid2)] $ \operation -> + Store.runStoreIO firstStore operation `shouldReturn` Right False + Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before + Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx + (expiredCompletion, completionRecovery) <- + timerRaceIO + (Store.runStoreIO firstStore $ completeTimerResume replacement (EventId sampleUuid2)) + (Store.runStoreIO secondStore recoverExpiredTimerResumes) + expiredCompletion `shouldBe` Right False + completionRecovery `shouldBe` Right 1 + Right (Right (Just finalClaim)) <- Store.runStoreIO firstStore $ claimDeadTimer request + (completed, noRecovery) <- + timerRaceIO + (Store.runStoreIO firstStore $ completeTimerResume finalClaim (EventId sampleUuid2)) + (Store.runStoreIO secondStore recoverExpiredTimerResumes) + completed `shouldBe` Right True + noRecovery `shouldBe` Right 0 + + describe "Keiro.Timer" $ around (withFreshStore fixture) $ do + it "guards dead resume ownership and retains attempts when parked" $ \storeHandle -> do + let tid = counterTimerRequest ^. #timerId + request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 2 60 + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" + Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request + resumeClaimTimer claim ^. #attempts `shouldBe` 1 + Store.runStoreIO storeHandle (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing + Store.runStoreIO storeHandle (markTimerFired tid (EventId sampleUuid2)) `shouldReturn` Right False + Store.runStoreIO storeHandle (cancelTimer tid) `shouldReturn` Right False + Store.runStoreIO storeHandle (deadLetterTimer tid "wrong") `shouldReturn` Right False + Store.runStoreIO storeHandle (requeueStuckTimer tid) `shouldReturn` Right False + Store.runStoreIO storeHandle (requeueStuckTimers 0 (resumeClaimLeaseUntil claim)) `shouldReturn` Right 0 + Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right True) + Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right True + Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request + resumeClaimTimer replacement ^. #attempts `shouldBe` 2 + Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right False + Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right False + Store.runStoreIO storeHandle (cancelTimerResume claim) `shouldReturn` Right False + Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right False) + Store.runStoreIO storeHandle (parkTimerResume replacement) `shouldReturn` Right True + Right (Right refused) <- Store.runStoreIO storeHandle $ claimDeadTimer request + isNothing refused `shouldBe` True + Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid + observed ^. #lastError `shouldBe` Just "deferred" + observed ^. #timer . #attempts `shouldBe` 2 + + it "refuses every ineligible claim without changing any persisted column" $ \storeHandle -> do + let tid = counterTimerRequest ^. #timerId + request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 1 60 + snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt + refused req = do + before <- snapshot + Right (Right result) <- Store.runStoreIO storeHandle $ claimDeadTimer req + isNothing result `shouldBe` True + snapshot `shouldReturn` before + refused request + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest + refused request + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + refused request + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" + refused (request & #processManagerName .~ "COUNTER") + refused (request & #expectedReason .~ "Deferred") + refused (request & #maxAttempts .~ 0) + refused request -- ordinary claim already consumed the ceiling + before <- snapshot + Right (Left badMax) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ (-1)) + badMax `shouldBe` InvalidTimerResumeMaxAttempts (-1) + forM_ [0, -1, maxBound] $ \seconds -> do + Right (Left badLease) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #leaseSeconds .~ seconds) + badLease `shouldBe` InvalidTimerResumeLeaseSeconds seconds + snapshot `shouldReturn` before + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement (case tid of TimerId uuid -> uuid) legacyDeadTimerReasonStmt + refused (request & #maxAttempts .~ 2) + + it "claims literal empty and Unicode reasons and preserves original work" $ \storeHandle -> do + forM_ (zip [1 ..] ["", "延期: café 日本語 🌱", "a%_\\'雪"]) $ \(n, reason) -> do + let original = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n) + tid = original ^. #timerId + request = DeadTimerClaimRequest tid (original ^. #processManagerName) reason 1 60 + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx original + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid reason + Right (Just before) <- Store.runStoreIO storeHandle $ lookupTimer tid + Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request + resumeClaimTimer claim `shouldBe` (before & #status .~ Firing & #attempts .~ 1) + Right (Right repeated) <- Store.runStoreIO storeHandle $ claimDeadTimer request + isNothing repeated `shouldBe` True + Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right True + Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid + inspection ^. #lastError `shouldBe` Just reason + inspection ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2) + Right (Right terminal) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ 2) + isNothing terminal `shouldBe` True + + it "expires without revival and re-parks independently of ordinary recovery" $ \storeHandle -> do + let tid = counterTimerRequest ^. #timerId + request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60 + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred" + Right (Right (Just old)) <- Store.runStoreIO storeHandle $ claimDeadTimer request + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction expireTimerResumesTx + Right before <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt + Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False) + Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False + Store.runStoreIO storeHandle (parkTimerResume old) `shouldReturn` Right False + Store.runStoreIO storeHandle (cancelTimerResume old) `shouldReturn` Right False + Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before + let options = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing + Store.runStoreIO storeHandle (runTimerWorkerWith Nothing options dueTimerTime (\_ -> error "foreground work reached background")) `shouldReturn` Right Nothing + Store.runStoreIO storeHandle recoverExpiredTimerResumes `shouldReturn` Right 0 + Right (Just parked) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid + parked ^. #timer . #status `shouldBe` Dead + parked ^. #timer . #attempts `shouldBe` 1 + parked ^. #lastError `shouldBe` Just "deferred" + Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request + Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False + Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False) + Store.runStoreIO storeHandle (cancelTimerResume replacement) `shouldReturn` Right True + Right (Right cancelled) <- Store.runStoreIO storeHandle $ claimDeadTimer request + isNothing cancelled `shouldBe` True + + it "inspects absent timers and preserves legacy metadata through every lifecycle" $ \storeHandle -> do + let tid = counterTimerRequest ^. #timerId + inspect reason = do + Right old <- Store.runStoreIO storeHandle $ lookupTimer tid + Right observed <- Store.runStoreIO storeHandle $ lookupTimerInspection tid + fmap (^. #timer) observed `shouldBe` old + fmap (^. #lastError) observed `shouldBe` Just reason + Store.runStoreIO storeHandle (lookupTimerInspection tid) `shouldReturn` Right Nothing + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest + inspect Nothing + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + inspect Nothing + Right True <- Store.runStoreIO storeHandle $ markTimerFired tid (EventId sampleUuid2) + inspect Nothing + Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid + observed ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2) + observed ^. #timer . #attempts `shouldBe` 1 + + it "preserves empty, populated, and Unicode dead reasons verbatim" $ \storeHandle -> do + forM_ (zip [1 ..] ["", " retry exhausted ", "延期: café 日本語 🌱"]) $ \(n, reason) -> do + let request = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n) + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) reason + Right old <- Store.runStoreIO storeHandle $ lookupTimer (request ^. #timerId) + Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection (request ^. #timerId) + Just (observed ^. #timer) `shouldBe` old + observed ^. #lastError `shouldBe` Just reason + + it "filters dead timers by exact owner and literal reason, preserving NULL" $ \storeHandle -> do + let fixtures = + [ (1, "A", Just "deferred: one"), + (2, "A", Just "deferred: 二"), + (3, "B", Just "deferred: three"), + (4, "A", Just "ordinary"), + (5, "A", Nothing), + (6, "A", Just ""), + (7, "A", Just "a%_\\'雪 tail"), + (8, "A", Just "aXX雪 tail"), + (9, "a", Just "Deferred: one") + ] + tid n = TimerId (UUID.fromWords 0 0 0 n) + check owner reason expected = do + Right (Right page) <- + Store.runStoreIO storeHandle $ + findDeadTimers (DeadTimerFilter owner reason) (DeadTimerPageRequest 100 Nothing) + fmap (^. #timer . #timerId) (page ^. #timers) `shouldBe` fmap tid expected + page ^. #nextAfterTimerId `shouldBe` Nothing + forM_ fixtures $ \(n, owner, reason) -> do + let request = counterTimerRequest & #timerId .~ tid n & #processManagerName .~ owner + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (tid n) (fromMaybe "legacy" reason) + when (isNothing reason) $ do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (UUID.fromWords 0 0 0 n) legacyDeadTimerReasonStmt + Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid n) + inspection ^. #lastError `shouldBe` Nothing + -- Include every non-dead lifecycle in the same manager/reason search space. + forM_ [10 .. 13] $ \n -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx (counterTimerRequest & #timerId .~ tid n & #processManagerName .~ "A") + pure () + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + Right True <- Store.runStoreIO storeHandle $ markTimerFired (tid 10) (EventId sampleUuid2) + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + Right True <- Store.runStoreIO storeHandle $ cancelTimer (tid 12) + Right (Just cancelled) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid 12) + cancelled ^. #timer . #status `shouldBe` Timer.Cancelled + check Nothing AnyTimerReason [1 .. 9] + check (Just "A") (ReasonPrefix "deferred:") [1, 2] + check Nothing (ReasonPrefix "deferred:") [1, 2, 3] + check (Just "a") AnyTimerReason [9] + check Nothing ReasonAbsent [5] + check Nothing (ReasonExact "") [6] + check Nothing (ReasonPrefix "") [1, 2, 3, 4, 6, 7, 8, 9] + check Nothing (ReasonExact "deferred: 二") [2] + check Nothing (ReasonPrefix "a%_\\'雪") [7] + check Nothing (ReasonExact "a%_\\'雪 tail") [7] + check Nothing (ReasonExact "DEFERRED: one") [] + check (Just "A' OR TRUE --") AnyTimerReason [] + + it "bounds pages, traverses UUID order, and leaves every stored column unchanged" $ \storeHandle -> do + forM_ [1 .. 101] $ \n -> do + let request = plainTimerRequest n + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) "deferred" + pure () + let snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt + readPage size cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest size cursor) + storedBefore <- snapshot + forM_ [-1, 0, 101, maxBound] $ \size -> + readPage size Nothing `shouldReturn` Right (Left (InvalidDeadTimerPageSize size)) + Right (Right first) <- readPage 100 Nothing + length (first ^. #timers) `shouldBe` 100 + first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 100 ^. #timerId) + readPage 100 Nothing `shouldReturn` Right (Right first) + Right (Right finalPage) <- readPage 100 (first ^. #nextAfterTimerId) + fmap (^. #timer . #timerId) (finalPage ^. #timers) `shouldBe` [plainTimerRequest 101 ^. #timerId] + finalPage ^. #nextAfterTimerId `shouldBe` Nothing + readPage 1 (Just (plainTimerRequest 101 ^. #timerId)) `shouldReturn` Right (Right (DeadTimerPage [] Nothing)) + let walk cursor = do + Right (Right page) <- readPage 1 cursor + let ids = fmap (^. #timer . #timerId) (page ^. #timers) + case page ^. #nextAfterTimerId of + Nothing -> pure ids + next -> (ids <>) <$> walk next + walk Nothing `shouldReturn` fmap ((^. #timerId) . plainTimerRequest) [1 .. 101] + Right (Just _) <- Store.runStoreIO storeHandle $ lookupTimerInspection (plainTimerRequest 1 ^. #timerId) + snapshot `shouldReturn` storedBefore + Store.runStoreIO storeHandle (runTimerWorker Nothing dueTimerTime (\_ -> pure (Just (EventId sampleUuid2)))) + `shouldReturn` Right Nothing + snapshot `shouldReturn` storedBefore + + it "continues after a deleted cursor and observes new eligibility only above it" $ \storeHandle -> do + let add n = do + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n) + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) "deferred" + pure () + readPage cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest 1 cursor) + mapM_ add [20, 40, 60] + Right (Right first) <- readPage Nothing + first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 20 ^. #timerId) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql + "DELETE FROM keiro.keiro_timers WHERE correlation_id = 'drain-20'; UPDATE keiro.keiro_timers SET status = 'cancelled' WHERE correlation_id = 'drain-40'" + mapM_ add [10, 30] + Right (Right second) <- readPage (first ^. #nextAfterTimerId) + fmap (^. #timer . #timerId) (second ^. #timers) `shouldBe` [plainTimerRequest 30 ^. #timerId] + Right (Right third) <- readPage (second ^. #nextAfterTimerId) + fmap (^. #timer . #timerId) (third ^. #timers) `shouldBe` [plainTimerRequest 60 ^. #timerId] + third ^. #nextAfterTimerId `shouldBe` Nothing + + it "renders authorized original work beyond empty pages and rechecks revoked permissions" $ \storeHandle -> do + let reason = "kioku:deferred:interactive-unavailable feature=summary details=保持" + deadFilter = DeadTimerFilter (Just "drain-pm") (ReasonPrefix "kioku:deferred:interactive-unavailable feature=") + entries = + [ (1, object ["space" Aeson..= ("hidden" :: Text), "work" Aeson..= ("secret" :: Text)]), + (2, object ["invalid" Aeson..= ("never render" :: Text)]), + (3, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("original work" :: Text)]), + (4, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("revoked work" :: Text)]) + ] + forM_ entries $ \(n, payload) -> do + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n & #payload .~ payload) + Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) reason + pure () + permissions <- newIORef (Set.singleton ("allowed" :: Text)) + let renderPage cursor = do + Right (Right page) <- Store.runStoreIO storeHandle $ findDeadTimers deadFilter (DeadTimerPageRequest 1 cursor) + fresh <- readIORef permissions + rendered <- fmap catMaybes $ forM (page ^. #timers) $ \listed -> do + Right inspected <- Store.runStoreIO storeHandle $ lookupTimerInspection (listed ^. #timer . #timerId) + pure $ do + inspection <- inspected + (space, work) <- + either (const Nothing) Just $ + parseEither (withObject "work" (\o -> (,) <$> o .: "space" <*> o .: "work")) (inspection ^. #timer . #payload) + if Set.member space fresh then Just (work :: Text, inspection ^. #lastError) else Nothing + pure (rendered, page ^. #nextAfterTimerId) + (hidden, next1) <- renderPage Nothing + hidden `shouldBe` [] + next1 `shouldSatisfy` isJust + (malformed, next2) <- renderPage next1 + malformed `shouldBe` [] + next2 `shouldSatisfy` isJust + (allowed, next3) <- renderPage next2 + allowed `shouldBe` [("original work", Just reason)] + writeIORef permissions Set.empty + renderPage next3 `shouldReturn` ([], Nothing) + + it "validates worker options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1)) + `shouldBeLeft` InvalidTimerMaxAttempts (-1) + mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0) + `shouldBeLeft` InvalidTimerRequeueStuckAfter 0 + + it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 11) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + let firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId)) + case workerResult of + Right (Just _) -> pure () + other -> expectationFailure ("expected a fired timer, got " <> show other) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + -- One scheduled+due row at the start of the pass: backlog gauge holds 1. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1) + -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0) + -- The claimed timer was due exactly at 'now' and is on its first attempt: + -- one fire.lag observation of 0 ms and one attempts observation of 1. + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)] + [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)] + + it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing. + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + case claimed of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + Right lookedUp <- + Store.runStoreIO storeHandle $ + lookupTimer (counterTimerRequest ^. #timerId) + fmap (^. #status) lookedUp `shouldBe` Just Firing + -- It surfaces as stuck under the permissive filter. + Right stuck <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime anyStuckTimer + fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId] + -- A bound it does not meet (only one attempt) excludes it. + Right unmatched <- + Store.runStoreIO storeHandle $ + findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5)) + unmatched `shouldBe` [] + -- Requeue is idempotent: True the first time, False once it is scheduled. + requeued <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeued `shouldBe` Right True + requeuedAgain <- + Store.runStoreIO storeHandle $ + requeueStuckTimer (counterTimerRequest ^. #timerId) + requeuedAgain `shouldBe` Right False + -- The ordinary loop re-claims and fires it exactly once. + let firedEventId = EventId sampleUuid2 + workerResult <- Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime $ \_ -> do + fired <- + runCommand + (defaultRunCommandOptions & #eventIds .~ [firedEventId]) + counterEventStream + (stream "timer-target") + (Add 7) + case fired of + Right _ -> pure (Just firedEventId) + Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing + case workerResult of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected re-fired timer, got " <> show other) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + Right targetEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10 + fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId] + + it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed ^. #status `shouldBe` Firing + realNow <- getCurrentTime + firedRef <- newIORef [] + let futureNow = addUTCTime 400 realNow + firedEventId = EventId sampleUuid2 + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow $ \timer -> do + liftIO (modifyIORef' firedRef (<> [timer ^. #timerId])) + pure (Just firedEventId) + case workerResult of + Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId + other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other) + firedTimers <- readIORef firedRef + firedTimers `shouldBe` [counterTimerRequest ^. #timerId] + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("fired", Nothing) + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "does not requeue a fresh firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing realNow $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + realNow <- getCurrentTime + firedRef <- newIORef False + let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just (EventId sampleUuid2)) + workerResult `shouldBe` Right Nothing + didFire <- readIORef firedRef + didFire `shouldBe` False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("firing", Nothing) + + it "does not claim a cancelled timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + cancelled <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelled `shouldBe` Right True + claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + claimed `shouldBe` Right Nothing + cancelledAgain <- + Store.runStoreIO storeHandle $ + cancelTimer (counterTimerRequest ^. #timerId) + cancelledAgain `shouldBe` Right False + + it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + firedRef <- newIORef False + let firedEventId = EventId sampleUuid2 + -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the + -- worker dead-letters instead of firing. + result <- Store.runStoreIO storeHandle $ + runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do + liftIO (writeIORef firedRef True) + pure (Just firedEventId) + case result of + Right (Just timer) -> + timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a claimed timer, got " <> show other) + -- The fire action never ran. + didFire <- readIORef firedRef + didFire `shouldBe` False + -- The row landed in 'dead' with the expected reason in last_error. + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0") + -- A dead row is never re-claimed. + secondWorkerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId)) + secondWorkerResult `shouldBe` Right Nothing + + it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + deadened <- + Store.runStoreIO storeHandle $ + deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter" + deadened `shouldBe` Right True + marked <- + Store.runStoreIO storeHandle $ + markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2) + marked `shouldBe` Right False + Right statusRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement sampleUuid timerStatusAndErrorStmt + statusRow `shouldBe` Just ("dead", Just "operator dead-letter") + + it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + scheduleTimerTx counterTimerRequest + -- Strand it in Firing by claiming without firing (a crashed worker). + Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime + -- A later pass finds nothing scheduled and due, but sees the stranded row. + workerResult <- + Store.runStoreIO storeHandle $ + runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing) + workerResult `shouldBe` Right Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- The one firing row is counted as stuck. + lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1) + -- It is not 'scheduled', so it does not show up as backlog. + lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Outbox.Kafka" $ do + it "converts an outbox row to a Kafka producer record" $ do + let envelope = sampleIntegrationEnvelope + row = sampleOutboxRow envelope + record = OutboxKafka.outboxRowToKafkaRecord row + record ^. #topic `shouldBe` envelope ^. #destination + record ^. #key `shouldBe` Just "order-123" + record ^. #payload `shouldBe` envelope ^. #payloadBytes + -- Headers include identity fields and content type. + let headers = record ^. #headers + messageIdHeader = Prelude.lookup "keiro-message-id" headers + messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa" + + it "drops the partition key when the envelope has no key" $ do + let envelope = sampleIntegrationEnvelope & #key .~ Nothing + record = OutboxKafka.integrationEventToKafkaRecord envelope + record ^. #key `shouldBe` Nothing + + describe "Keiro.Outbox producer-identity" $ do + let sourceId = EventId (UUID.fromWords 0 0 0 1) + recorded = recordedFromEventId sourceId (CounterAdded 1) + identity = ProducerOutbox.deriveProducerIdentity sampleProducer (ProducerOutbox.ProducerEventKey sourceId 0) + enqueue producer event index draft storeHandle = Store.runStoreIO storeHandle (Store.runTransaction (ProducerOutbox.enqueueProducerEventTx producer event index draft)) + runDraft = enqueue sampleProducer recorded 0 + rows storeHandle = Store.runStoreIO storeHandle (ProducerOutbox.listOutbox "ordering") + it "pins the version-1 SHA-256/UUIDv8 vector" $ do + identity ^. #outboxId `shouldBe` OutboxId (UUID.fromWords 0x61dd62b4 0xbbfe81ce 0x96346ce6 0xafd48517) + identity ^. #messageId `shouldBe` "msg_v1_61dd62b4bbfef1ce56346ce6afd485172774bc060102e5cf455e39bd0edfa84b" + identity ^. #derivationVersion `shouldBe` 1 + it "pins canonical content digest independently of storage lifecycle" $ do + ProducerOutbox.producerContentDigest (draftToEvent "ordering" "vector" sampleDraft) + `shouldBe` "8b2eb3af1146c43d592f0ec19519609d4316ba4c83133eeb059a115a0517e323" + it "separates source, name, event, index, tuple boundaries and UTF-8" $ do + let key = ProducerOutbox.ProducerEventKey sourceId 0 + derive s n k = ProducerOutbox.deriveIdentity s n "msg" k + values = + [ derive "a" "bc" key, + derive "ab" "c" key, + derive "a" "b" key, + derive "a" "b" (key & #emissionIndex .~ 1), + derive "a" "b" (key & #sourceEventId .~ EventId sampleUuid), + derive "a" "\x0101" key, + derive "a" "\SOH" key + ] + Set.size (Set.fromList (fmap (^. #outboxId) values)) `shouldBe` length values + it "rejects an empty namespace before subscription startup" $ do + case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "") of + Left InvalidMessageIdPrefix {} -> pure () + _ -> expectationFailure "empty namespace was accepted" + it "replays after closing and reopening the store with one unchanged row" $ + withFreshDatabase fixture $ \conn -> do + before <- Store.withStore (Store.defaultConnectionSettings conn) $ \storeHandle -> do + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + Right [row] <- rows storeHandle + pure row + Store.withStore (Store.defaultConnectionSettings conn) $ \storeHandle -> do + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + rows storeHandle `shouldReturn` Right [before] + around (withFreshStore fixture) $ do + it "returns inserted, identical retry, and defaults recorded provenance" $ \storeHandle -> do + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + Right [before] <- rows storeHandle + (before ^. #event) ^. #sourceEventId `shouldBe` Just sourceId + (before ^. #event) ^. #sourceGlobalPosition `shouldBe` Just (recorded ^. #globalPosition) + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + rows storeHandle `shouldReturn` Right [before] + it "rolls back enqueue with a failed checkpoint and reuses both IDs on redelivery" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "CREATE TABLE producer_checkpoint (position bigint NOT NULL); INSERT INTO producer_checkpoint VALUES (0)" + let checkpoint = + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement () (preparable "SELECT position FROM producer_checkpoint" E.noParams (D.singleRow (D.column (D.nonNullable D.int8)))) + result <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + outcome <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 sampleDraft + Tx.sql "UPDATE producer_checkpoint SET position = 1" + Tx.condemn + pure outcome + result `shouldBe` Right (ProducerOutbox.ProducerInserted identity) + rows storeHandle `shouldReturn` Right [] + checkpoint `shouldReturn` Right 0 + retried <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + outcome <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 sampleDraft + Tx.sql "UPDATE producer_checkpoint SET position = 1" + pure outcome + retried `shouldBe` Right (ProducerOutbox.ProducerInserted identity) + checkpoint `shouldReturn` Right 1 + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + Right retained <- rows storeHandle + length retained `shouldBe` 1 + it "concurrent identical attempts converge to one inserted and one duplicate" $ \storeHandle -> do + a <- newEmptyMVar + b <- newEmptyMVar + _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar a) + _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar b) + outcomes <- sequence [takeMVar a, takeMVar b] + length (filter (== Right (ProducerOutbox.ProducerInserted identity)) outcomes) `shouldBe` 1 + length (filter (== Right (ProducerOutbox.ProducerDuplicateIdentical identity)) outcomes) `shouldBe` 1 + Right retained <- rows storeHandle + length retained `shouldBe` 1 + it "concurrent changed content selects one winner and reports one conflict" $ \storeHandle -> do + a <- newEmptyMVar + b <- newEmptyMVar + _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar a) + _ <- forkIO (runDraft (sampleDraft & #payloadBytes .~ "changed-secret") storeHandle >>= putMVar b) + outcomes <- sequence [takeMVar a, takeMVar b] + length (filter (== Right (ProducerOutbox.ProducerInserted identity)) outcomes) `shouldBe` 1 + length (filter (== Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.PayloadField NonEmpty.:| []))) outcomes) `shouldBe` 1 + Right retained <- rows storeHandle + length retained `shouldBe` 1 + it "detects drift in every envelope field class without changing the original row" $ \storeHandle -> do + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + Right [before] <- rows storeHandle + let cases = + [ (ProducerOutbox.RoutingField, sampleDraft & #destination .~ "elsewhere"), + (ProducerOutbox.RoutingField, sampleDraft & #key .~ Nothing), + (ProducerOutbox.SchemaField, sampleDraft & #eventType .~ "Renamed"), + (ProducerOutbox.SchemaField, sampleDraft & #schemaVersion .~ 2), + (ProducerOutbox.SchemaField, sampleDraft & #schemaReference ?~ SchemaReference (Just "r") (Just "s") (Just 2) (Just 3) (Just "f")), + (ProducerOutbox.SchemaField, sampleDraft & #contentType .~ OtherContentType "application/json; charset=utf-8"), + (ProducerOutbox.PayloadField, sampleDraft & #payloadBytes .~ "private-payload"), + (ProducerOutbox.OccurredAtField, sampleDraft & #occurredAt %~ addUTCTime 1), + (ProducerOutbox.CausalField, sampleDraft & #causationId ?~ sourceId), + (ProducerOutbox.CausalField, sampleDraft & #correlationId ?~ sourceId), + (ProducerOutbox.TraceField, sampleDraft & #traceContext ?~ TraceContext "parent" (Just "state")), + (ProducerOutbox.AttributesField, sampleDraft & #attributes ?~ object ["private" Aeson..= True]), + (ProducerOutbox.ProvenanceField, sampleDraft & #sourceEventId ?~ EventId sampleUuid), + (ProducerOutbox.ProvenanceField, sampleDraft & #sourceGlobalPosition ?~ GlobalPosition 99) + ] + forM_ cases $ \(field, draft) -> do + result <- runDraft draft storeHandle + result `shouldBe` Right (ProducerOutbox.ProducerIdentityConflict identity (field NonEmpty.:| [])) + show result `shouldSatisfy` (not . isInfixOf "private-payload") + rows storeHandle `shouldReturn` Right [before] + it "normalizes sub-microsecond time and JSON object order across storage" $ \storeHandle -> do + let draft = + sampleDraft + & #occurredAt + %~ addUTCTime 0.123456789 + & #attributes + ?~ object ["b" Aeson..= (2 :: Int), "a" Aeson..= (1 :: Int)] + runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + runDraft (draft & #attributes ?~ object ["a" Aeson..= (1 :: Int), "b" Aeson..= (2 :: Int)]) storeHandle + `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + it "distinguishes absent attributes from JSON null and preserves raw MIME text" $ \storeHandle -> do + let draft = sampleDraft & #attributes .~ Nothing & #contentType .~ OtherContentType "Application/JSON; charset=utf-8" + runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + runDraft (draft & #attributes ?~ Aeson.Null) storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.AttributesField NonEmpty.:| [])) + it "keeps wire identity after successful-row retention expires" $ \storeHandle -> do + _ <- runDraft sampleDraft storeHandle + Right summary <- Store.runStoreIO storeHandle $ publishClaimedOutbox (perRow (\_ -> pure PublishSucceeded)) defaultPublishOptions Nothing + summary ^. #published `shouldBe` 1 + Right [sent] <- rows storeHandle + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + rows storeHandle `shouldReturn` Right [sent] + now <- getCurrentTime + Store.runStoreIO storeHandle (garbageCollectSent 0 (addUTCTime 1 now)) `shouldReturn` Right 1 + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity) + it "different producer names and source events insert distinct identities" $ \storeHandle -> do + let producer2 = sampleProducer & #name .~ ("second-producer" :: Text) + recorded2 = recorded & #eventId .~ EventId sampleUuid + _ <- runDraft sampleDraft storeHandle + _ <- enqueue producer2 recorded 0 sampleDraft storeHandle + _ <- enqueue sampleProducer recorded2 0 sampleDraft storeHandle + Right retained <- rows storeHandle + length retained `shouldBe` 3 + Set.size (Set.fromList (fmap (^. #outboxId) retained)) `shouldBe` 3 + it "preserves a rejected publication and its audit data on replay" $ \storeHandle -> do + _ <- runDraft sampleDraft storeHandle + rejection <- shouldBeRight (mkPublishRejection "refused" (Just "audit")) + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow (\_ -> pure (PublishRejected rejection))) defaultPublishOptions Nothing + summary ^. #rejected `shouldBe` 1 + Right [before] <- rows storeHandle + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity) + rows storeHandle `shouldReturn` Right [before] + it "reports both unique-identity collision routes and keeps explicit envelopes usable" $ \storeHandle -> do + let event = + draftToEvent "ordering" (identity ^. #messageId) sampleDraft + & #sourceEventId + ?~ sourceId + & #sourceGlobalPosition + ?~ GlobalPosition 1 + Store.runStoreIO storeHandle (Store.runTransaction (enqueueIntegrationEventTx (OutboxId outboxUuid1) event)) `shouldReturn` Right () + Store.runStoreIO storeHandle (Store.runTransaction (enqueueIntegrationEventTx (OutboxId outboxUuid1) event)) `shouldReturn` Right () + runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.IdentityField NonEmpty.:| [])) + Right retained <- rows storeHandle + length retained `shouldBe` 1 + it "treats namespace drift as an identity conflict on the outbox primary key" $ \storeHandle -> do + _ <- runDraft sampleDraft storeHandle + let changed = sampleProducer & #messageIdPrefix .~ ("event" :: Text) + changedId = ProducerOutbox.deriveProducerIdentity changed (ProducerOutbox.ProducerEventKey sourceId 0) + enqueue changed recorded 0 sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict changedId (ProducerOutbox.IdentityField NonEmpty.:| [])) + it "records a distinct conflict metric after a checkpoint rollback" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + Right first <- runDraft sampleDraft storeHandle + ProducerOutbox.recordProducerEnqueueOutcome (Just metrics) first + Right outcome <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + result <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 (sampleDraft & #payloadBytes .~ "secret") + Tx.condemn + pure result + ProducerOutbox.recordProducerEnqueueOutcome (Just metrics) outcome + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.outbox.identity.conflict" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1) + + describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do + it "validates terminal publication rejection data at its public boundary" $ \_storeHandle -> do + let validCode64 = "a" <> Text.replicate 63 "z" + validDetail1024 = Text.replicate 1024 "x" + validUtf8Detail = Text.replicate 512 "é" + valid <- shouldBeRight (mkPublishRejection validCode64 (Just validDetail1024)) + publishRejectionCode valid `shouldBe` validCode64 + publishRejectionDetail valid `shouldBe` Just validDetail1024 + shouldBeRight_ (mkPublishRejection "authorization.denied_v2" Nothing) + shouldBeRight_ (mkPublishRejection "invalid-destination" (Just validUtf8Detail)) + mkPublishRejection "" Nothing + `shouldBeLeft` InvalidPublishRejectionCode "" + mkPublishRejection "Uppercase" Nothing + `shouldBeLeft` InvalidPublishRejectionCode "Uppercase" + mkPublishRejection "1leading-digit" Nothing + `shouldBeLeft` InvalidPublishRejectionCode "1leading-digit" + mkPublishRejection "contains/slash" Nothing + `shouldBeLeft` InvalidPublishRejectionCode "contains/slash" + mkPublishRejection ("a" <> Text.replicate 64 "z") Nothing + `shouldBeLeft` InvalidPublishRejectionCode ("a" <> Text.replicate 64 "z") + mkPublishRejection "invalid-destination" (Just "") + `shouldBeLeft` PublishRejectionDetailEmpty + mkPublishRejection "invalid-destination" (Just (Text.replicate 513 "é")) + `shouldBeLeft` PublishRejectionDetailTooLong 1026 + + it "validates publisher options before startup" $ \_storeHandle -> do + shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions) + mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0) + `shouldBeLeft` InvalidOutboxBatchSize 0 + mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0) + `shouldBeLeft` InvalidOutboxMaxAttempts 0 + mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0) + `shouldBeLeft` InvalidOutboxPublishingTimeout 0 + mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1)) + `shouldBeLeft` InvalidConstantBackoff (-1) + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 0, + maxDelay = 1, + multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffInitial 0 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 1, + maxDelay = 10, + multiplier = 0.5 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5 + mkOutboxPublishOptions + ( defaultPublishOptions + & #backoff + .~ ExponentialBackoff + ExponentialBackoffOptions + { initial = 5, + maxDelay = 4, + multiplier = 2 + } + ) + `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4 + + it "enqueues and looks up an outbox row" $ \storeHandle -> do + let envelope = sampleIntegrationEnvelope + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid envelope) + lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid) + case lookedUp of + Right (Just row) -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPending + row ^. #attemptCount `shouldBe` 0 + row ^. #event . #messageId `shouldBe` envelope ^. #messageId + row ^. #event . #destination `shouldBe` envelope ^. #destination + row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes + other -> expectationFailure ("expected enqueued row, got " <> show other) + + it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + case rows of + [row] -> do + row ^. #outboxId `shouldBe` oid + row ^. #status `shouldBe` OutboxPublishing + row ^. #attemptCount `shouldBe` 1 + other -> expectationFailure ("expected one claimed row, got " <> show other) + + it "claims contiguous per-key runs in one pass" $ \storeHandle -> do + let keyedRows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A"), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A"), + (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A"), + (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B"), + (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B"), + (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) keyedRows + now <- getCurrentTime + Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows + fmap (^. #attemptCount) rows `shouldBe` replicate 8 1 + + it "does not let a backoff head starve other keys" $ \storeHandle -> do + let a1Id = outboxIdFromOrdinal 1 + a2Id = outboxIdFromOrdinal 2 + b1Id = outboxIdFromOrdinal 3 + b2Id = outboxIdFromOrdinal 4 + rows = + [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A"), + (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A"), + (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B"), + (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B") + ] + failA1 row + | row ^. #outboxId == a1Id = pure (PublishFailed "wait") + | otherwise = pure PublishSucceeded + opts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 3600 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing) + failedPass ^. #retried `shouldBe` 1 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id] + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + + it "claims contiguous per-source runs in one pass" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing), + (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` fmap fst rows + + it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A"), + (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A"), + (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A") + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + now <- getCurrentTime + Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows + Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + secondClaim `shouldBe` [] + + it "marks a claimed row as sent with published_at set" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #publishedAt `shouldSatisfy` isJust + row ^. #lastError `shouldBe` Nothing + + it "finalizes rejection exactly once with durable typed audit data" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "sink policy refused this message")) + replacement <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + firstClaimAt <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 firstClaimAt) + Right (Just OutboxFailed) <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxFailedTx oid "transient predecessor" 5 0 firstClaimAt) + secondClaimAt <- getCurrentTime + Right [claimed] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 secondClaimAt) + rejectedAt <- getCurrentTime + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxRejectedTx oid rejection rejectedAt) + Right False <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxRejectedTx oid replacement (addUTCTime 60 rejectedAt)) + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxRejected + row ^. #attemptCount `shouldBe` 2 + row ^. #nextAttemptAt `shouldBe` claimed ^. #nextAttemptAt + row ^. #lastError `shouldBe` Nothing + row ^. #publishedAt `shouldBe` Nothing + row ^. #rejectedAt `shouldBe` Just rejectedAt + row ^. #rejection `shouldBe` Just rejection + + it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stranded ^. #status `shouldBe` OutboxPublishing + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + noPublish ^. #claimed `shouldBe` 0 + Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid) + stillStranded ^. #status `shouldBe` OutboxPublishing + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + maintenance ^. #deadLettered `shouldBe` 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + published <- readIORef publishedRef + published `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do + let firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key" + second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx firstId first) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx secondId second) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now) + claimedFirst ^. #outboxId `shouldBe` firstId + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow) + publishedRef <- newIORef [] + let publish row = do + liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId])) + pure PublishSucceeded + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 1 + Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + firstPass ^. #published `shouldBe` 2 + Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + secondPass ^. #published `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` [firstId, secondId] + Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + + it "does not reclaim a recently claimed row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + publishedRef <- newIORef (0 :: Int) + let publish _ = do + liftIO (modifyIORef' publishedRef (+ 1)) + pure PublishSucceeded + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 0 + published <- readIORef publishedRef + published `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxPublishing + + it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do + let throwId = OutboxId outboxUuid1 + okId = OutboxId outboxUuid2 + throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key" + okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + let publish row + | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded")) + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #retried `shouldBe` 2 + summary ^. #published `shouldBe` 0 + Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId) + throwRow ^. #status `shouldBe` OutboxFailed + throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxFailed + okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded") + + it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultMaintenanceOptions & #maxAttempts .~ 1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let pastNow = addUTCTime (-3600) now + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow) + Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing) + summary ^. #requeued `shouldBe` 0 + summary ^. #deadLettered `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + let publish _ = pure (PublishFailed "boom") + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + now <- getCurrentTime + Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now) + marked `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + + it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-1" + & #key + .~ Just "order-789" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + Right summary <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + summary ^. #dead `shouldBe` 0 + Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId) + okRow ^. #status `shouldBe` OutboxSent + Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId) + failRow ^. #status `shouldBe` OutboxFailed + failRow ^. #lastError `shouldBe` Just "broker unreachable" + + it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do + let rows = + [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key") + | i <- [1 .. 10 :: Int] + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + invocationRef <- newIORef (0 :: Int) + let publish claimed = do + liftIO (modifyIORef' invocationRef (+ 1)) + pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed] + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 10 + summary ^. #published `shouldBe` 10 + invocations <- readIORef invocationRef + invocations `shouldBe` 1 + for_ (fmap fst rows) $ \oid -> do + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + + it "finalizes a mid-run rejection and continues the same-key suffix" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + rows = + [ (row1Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-1" & #key .~ Just "reject-run-key"), + (row2Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-2" & #key .~ Just "reject-run-key"), + (row3Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-3" & #key .~ Just "reject-run-key") + ] + rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "the configured sink cannot accept this event type")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + let publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row2Id + then PublishRejected rejection + else PublishSucceeded + ) + | row <- claimed + ] + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #claimed `shouldBe` 3 + summary ^. #published `shouldBe` 2 + summary ^. #rejected `shouldBe` 1 + summary ^. #retried `shouldBe` 0 + Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) + Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + row1 ^. #status `shouldBe` OutboxSent + row2 ^. #status `shouldBe` OutboxRejected + row2 ^. #rejection `shouldBe` Just rejection + row3 ^. #status `shouldBe` OutboxSent + + it "redelivers callbacks after a pre-commit finalization failure" $ \storeHandle -> do + let sentId = outboxIdFromOrdinal 1 + rejectedId = outboxIdFromOrdinal 2 + rows = + [ (sentId, sampleIntegrationEnvelope & #messageId .~ "precommit-sent" & #key .~ Just "precommit-key"), + (rejectedId, sampleIntegrationEnvelope & #messageId .~ "precommit-rejected" & #key .~ Just "precommit-key") + ] + rejection <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + callbackInvocations <- newIORef [] + let publish claimed = do + liftIO (modifyIORef' callbackInvocations (fmap (^. #outboxId) claimed :)) + pure + [ (row ^. #outboxId, if row ^. #outboxId == rejectedId then PublishRejected rejection else PublishSucceeded) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql + "ALTER TABLE keiro.keiro_outbox ADD CONSTRAINT keiro_outbox_test_rejection_block CHECK (status <> 'rejected')" + first <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + first `shouldSatisfy` \case + Left _ -> True + Right _ -> False + Right (Just stillPublishingSent) <- Store.runStoreIO storeHandle (lookupOutbox sentId) + Right (Just stillPublishingRejected) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId) + stillPublishingSent ^. #status `shouldBe` OutboxPublishing + stillPublishingRejected ^. #status `shouldBe` OutboxPublishing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_outbox DROP CONSTRAINT keiro_outbox_test_rejection_block" + now <- getCurrentTime + let strandedAt = addUTCTime (-3600) now + maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1 + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt sentId strandedAt) + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt rejectedId strandedAt) + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass maintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 2 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #rejected `shouldBe` 1 + Right (Just sentRow) <- Store.runStoreIO storeHandle (lookupOutbox sentId) + Right (Just rejectedRow) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId) + sentRow ^. #status `shouldBe` OutboxSent + rejectedRow ^. #status `shouldBe` OutboxRejected + invocations <- readIORef callbackInvocations + invocations `shouldBe` replicate 2 [sentId, rejectedId] + + it "treats rejection as terminal for per-source ordering" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + sourceEvent oid messageId = + (oid, sampleIntegrationEnvelope & #messageId .~ messageId & #source .~ "reject-source" & #key .~ Nothing) + rows = + [ sourceEvent row1Id "reject-source-1", + sourceEvent row2Id "reject-source-2", + sourceEvent row3Id "reject-source-3" + ] + rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + let publish claimed = + pure + [ (row ^. #outboxId, if row ^. #outboxId == row2Id then PublishRejected rejection else PublishSucceeded) + | row <- claimed + ] + opts = defaultPublishOptions & #orderingPolicy .~ PerSourceStream + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing) + summary ^. #published `shouldBe` 2 + summary ^. #rejected `shouldBe` 1 + Right (Just successor) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + successor ^. #status `shouldBe` OutboxSent + + it "counts only a rejection finalization that wins the publishing-state race" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + let strandedAt = addUTCTime (-3600) now + maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1 + publish _ = do + backdateOutboxUpdatedAt oid strandedAt + _ <- outboxMaintenancePass maintenanceOptions Nothing + pure (PublishRejected rejection) + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing + summary ^. #claimed `shouldBe` 1 + summary ^. #published `shouldBe` 0 + summary ^. #rejected `shouldBe` 0 + summary ^. #retried `shouldBe` 0 + summary ^. #dead `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxFailed + row ^. #rejection `shouldBe` Nothing + + it "excludes rejected rows from claims, maintenance, backlog, and sent garbage collection" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + rejection <- shouldBeRight (mkPublishRejection "invalid.destination" (Just "destination was removed")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) defaultPublishOptions Nothing + summary ^. #rejected `shouldBe` 1 + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid (addUTCTime (-3600) now)) + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) + claimed `shouldBe` [] + Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing) + maintenance ^. #requeued `shouldBe` 0 + maintenance ^. #deadLettered `shouldBe` 0 + maintenance ^. #backlog `shouldBe` 0 + Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 0 now) + deleted `shouldBe` 0 + Right (Just retained) <- Store.runStoreIO storeHandle (lookupOutbox oid) + retained ^. #status `shouldBe` OutboxRejected + + it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + row5Id = outboxIdFromOrdinal 5 + ids = [row1Id, row2Id, row3Id, row4Id, row5Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key") + | (i, oid) <- zip [1 .. 5 :: Int] ids + ] + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row3Id + then PublishFailed "pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #published `shouldBe` 2 + summary ^. #retried `shouldBe` 3 + Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id) + Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id) + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id) + row1 ^. #status `shouldBe` OutboxSent + row2 ^. #status `shouldBe` OutboxSent + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 1 + row3 ^. #lastError `shouldBe` Just "pivot failed" + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed" + row5 ^. #status `shouldBe` OutboxFailed + row5 ^. #attemptCount `shouldBe` 0 + + it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do + let rowA1 = outboxIdFromOrdinal 1 + rowB1 = outboxIdFromOrdinal 2 + rowA2 = outboxIdFromOrdinal 3 + rowB2 = outboxIdFromOrdinal 4 + mkRow oid src msgId = + (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing) + rows = + [ mkRow rowA1 "per-source-a" "ps-a1", + mkRow rowB1 "per-source-b" "ps-b1", + mkRow rowA2 "per-source-a" "ps-a2", + mkRow rowB2 "per-source-b" "ps-b2" + ] + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == rowA2 + then PublishFailed "source-a pivot failed" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 4 + summary ^. #published `shouldBe` 3 + summary ^. #retried `shouldBe` 1 + Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1) + Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2) + Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1) + Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2) + a1 ^. #status `shouldBe` OutboxSent + a2 ^. #status `shouldBe` OutboxFailed + a2 ^. #attemptCount `shouldBe` 1 + a2 ^. #lastError `shouldBe` Just "source-a pivot failed" + b1 ^. #status `shouldBe` OutboxSent + b2 ^. #status `shouldBe` OutboxSent + + it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + now <- getCurrentTime + Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now) + Right lateResult <- + Store.runStoreIO storeHandle $ + Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now) + lateResult `shouldBe` Nothing + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxSent + row ^. #lastError `shouldBe` Nothing + + it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do + let headId = outboxIdFromOrdinal 1 + tailId = outboxIdFromOrdinal 2 + rows = + [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key"), + (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key") + ] + OutboxId headUuid = headId + holdClaimSql = + TE.encodeUtf8 $ + "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '" + <> UUID.toText headUuid + <> "'" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + holderDone <- newEmptyMVar + _ <- forkIO $ do + holder <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.sql holdClaimSql + Tx.sql "SELECT pg_sleep(2)" + putMVar holderDone holder + -- Let the holder acquire its uncommitted row lock, then race a claim. + threadDelay 500000 + now <- getCurrentTime + Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now) + fmap (^. #outboxId) claimed `shouldBe` [] + Right () <- takeMVar holderDone + pure () + + it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + ids = [row1Id, row2Id, row3Id, row4Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key") + | (i, oid) <- zip [1 .. 4 :: Int] ids + ] + publishRef = fmap (^. #outboxId) + publish claimed = + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row2Id + then PublishFailed "stop here" + else PublishSucceeded + ) + | row <- claimed + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + seenRef <- newIORef [] + let trackedPublish claimed = do + liftIO (modifyIORef' seenRef (<> publishRef claimed)) + publish claimed + opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 3 + summary ^. #haltedOn `shouldBe` Just row2Id + seen <- readIORef seenRef + seen `shouldBe` take 2 ids + Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id) + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + row3 ^. #status `shouldBe` OutboxFailed + row3 ^. #attemptCount `shouldBe` 0 + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + + it "StopTheLine continues after rejection and halts only on transient failure" $ \storeHandle -> do + let row1Id = outboxIdFromOrdinal 1 + row2Id = outboxIdFromOrdinal 2 + row3Id = outboxIdFromOrdinal 3 + row4Id = outboxIdFromOrdinal 4 + ids = [row1Id, row2Id, row3Id, row4Id] + rows = + [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-reject-" <> Text.pack (show i)) & #key .~ Just "stop-reject-key") + | (i, oid) <- zip [1 .. 4 :: Int] ids + ] + rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + traverse_ (uncurry enqueueIntegrationEventTx) rows + seenRef <- newIORef [] + let publish claimed = do + liftIO (modifyIORef' seenRef (<> fmap (^. #outboxId) claimed)) + pure + [ ( row ^. #outboxId, + if row ^. #outboxId == row1Id + then PublishRejected rejection + else + if row ^. #outboxId == row3Id + then PublishFailed "stop after rejection" + else PublishSucceeded + ) + | row <- claimed + ] + opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0 + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #rejected `shouldBe` 1 + summary ^. #retried `shouldBe` 2 + summary ^. #haltedOn `shouldBe` Just row3Id + readIORef seenRef `shouldReturn` take 3 ids + Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id) + row4 ^. #status `shouldBe` OutboxFailed + row4 ^. #attemptCount `shouldBe` 0 + + it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do + let okId = outboxIdFromOrdinal 1 + missingId = outboxIdFromOrdinal 2 + okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key" + missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key" + publish claimed = + pure + [ (row ^. #outboxId, PublishSucceeded) + | row <- claimed, + row ^. #outboxId == okId + ] + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + enqueueIntegrationEventTx okId okEvent + enqueueIntegrationEventTx missingId missingEvent + Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing) + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId) + missingRow ^. #status `shouldBe` OutboxFailed + missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome" + + it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do + let oid = OutboxId outboxUuid1 + event = sampleIntegrationEnvelope & #key .~ Nothing + opts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 3 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid event) + let publish _ = pure (PublishFailed "broker exploded") + -- First two failures retain Failed status. + Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s1 ^. #retried `shouldBe` 1 + s1 ^. #dead `shouldBe` 0 + Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s2 ^. #retried `shouldBe` 1 + s2 ^. #dead `shouldBe` 0 + -- Third failure crosses the threshold. + Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + s3 ^. #dead `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid) + row ^. #status `shouldBe` OutboxDead + -- A dead row is not claimable. + now <- getCurrentTime + Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now) + reclaimed `shouldBe` [] + + it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do + let oldSentId = OutboxId outboxUuid1 + recentSentId = OutboxId outboxUuid2 + failedId = OutboxId outboxUuid3 + deadId = OutboxId outboxUuid4 + base = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed")) + let firstPass row + | row ^. #outboxId == failedId = pure (PublishFailed "keep failed") + | otherwise = pure PublishSucceeded + firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #orderingPolicy + .~ BestEffort + & #backoff + .~ ConstantBackoff 3600 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead")) + let deadPass row + | row ^. #outboxId == deadId = pure (PublishFailed "keep dead") + | otherwise = pure PublishSucceeded + deadPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 1 + & #orderingPolicy + .~ BestEffort + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing) + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now)) + Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now) + deleted `shouldBe` 1 + Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId) + oldRow `shouldBe` Nothing + Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId) + recentRow ^. #status `shouldBe` OutboxSent + Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId) + failedRow ^. #status `shouldBe` OutboxFailed + Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId) + deadRow ^. #status `shouldBe` OutboxDead + + it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do + let a1Id = OutboxId outboxUuid1 + a2Id = OutboxId outboxUuid2 + b1Id = OutboxId outboxUuid3 + a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1" + a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1" + b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2" + -- Insert in created_at order (a1 first, then a2, then b1). + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a1Id a1) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx a2Id a2) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx b1Id b1) + claimed <- newIORef [] + let publish row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + if row ^. #outboxId == a1Id + then pure (PublishFailed "broker hiccup") + else pure PublishSucceeded + -- First pass: with a one-row batch, a1 fails and both later rows remain pending. + let firstPassOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing) + summary1 ^. #claimed `shouldBe` 1 + claimedIds <- readIORef claimed + claimedIds `shouldSatisfy` (a2Id `notElem`) + claimedIds `shouldSatisfy` (a1Id `elem`) + claimedIds `shouldSatisfy` (b1Id `notElem`) + Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id) + a1Row ^. #status `shouldBe` OutboxFailed + Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id) + b1Row ^. #status `shouldBe` OutboxPending + Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row ^. #status `shouldBe` OutboxPending + -- Drive a1 to terminal sent state so a2 can move. One pass claims a1 + -- (now that next_attempt_at has passed). A second pass claims a2, + -- which becomes head-of-line once a1 reaches `sent`. + writeIORef claimed [] + let publishOk row = do + liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ()))) + pure PublishSucceeded + retryOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing) + claimedIds2 <- readIORef claimed + claimedIds2 `shouldSatisfy` (a1Id `elem`) + claimedIds2 `shouldSatisfy` (a2Id `elem`) + claimedIds2 `shouldSatisfy` (b1Id `elem`) + Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id) + a2Row' ^. #status `shouldBe` OutboxSent + + it "allows null-keyed rows to publish independently" $ \storeHandle -> do + let n1 = OutboxId outboxUuid1 + n2 = OutboxId outboxUuid2 + e = sampleIntegrationEnvelope & #key .~ Nothing + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2")) + let publish row + | row ^. #outboxId == n1 = pure (PublishFailed "transient") + | otherwise = pure PublishSucceeded + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing + summary ^. #claimed `shouldBe` 2 + summary ^. #published `shouldBe` 1 + summary ^. #retried `shouldBe` 1 + + it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do + Right minted <- + Store.runStoreIO storeHandle (freshIntegrationEvent sampleProducer sampleDraft) + minted ^. #source `shouldBe` "ordering" + minted ^. #destination `shouldBe` "billing.orders.v1" + Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True + + it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do + shouldBeRight_ (mkIntegrationProducer sampleProducer) + case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of + Left (InvalidMessageIdPrefix prefix reason) -> do + prefix `shouldBe` "Bad-Prefix" + reason `shouldSatisfy` (not . Text.null) + other -> expectationFailure ("expected invalid prefix, got " <> show (void other)) + + it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do + let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft + event ^. #messageId `shouldBe` "msg-fixed-1" + event ^. #source `shouldBe` "ordering" + event ^. #destination `shouldBe` "billing.orders.v1" + + it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do + Right ids <- + Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int]) + length ids `shouldBe` 4 + length (uniqueIds ids) `shouldBe` 4 + + it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + okEvent = sampleIntegrationEnvelope + failEvent = + sampleIntegrationEnvelope + & #messageId + .~ "msg-fail-otel-1" + & #key + .~ Just "order-otel-fail" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | otherwise = pure (PublishFailed "broker unreachable") + opts = defaultPublishOptions & #tracer ?~ tracer + Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing) + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 1 + case spans of + [batchSpan] -> do + csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination)) + show (csKind batchSpan) `shouldBe` "Producer" + textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish" + textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send" + textAttr (csAttributes batchSpan) "messaging.destination.name" + `shouldBe` Just (okEvent ^. #destination) + textAttr (csAttributes batchSpan) "messaging.kafka.message.key" + `shouldBe` (okEvent ^. #key) + intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2 + textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed" + case csStatus batchSpan of + Error msg -> msg `shouldBe` "broker unreachable" + other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other) + other -> expectationFailure ("expected one batch span, got " <> show (length other)) + + it "does not mark a terminal rejection span as an error" $ \storeHandle -> do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "operator policy")) + let tracer = makeTracer provider "keiro-test" tracerOptions + oid = OutboxId outboxUuid1 + opts = defaultPublishOptions & #tracer ?~ tracer + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope) + Right summary <- + Store.runStoreIO storeHandle $ + publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) opts Nothing + summary ^. #rejected `shouldBe` 1 + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + case spans of + [batchSpan] -> do + textAttr (csAttributes batchSpan) "error.type" `shouldBe` Nothing + case csStatus batchSpan of + Unset -> pure () + Ok -> pure () + other -> expectationFailure ("expected rejection span to be Unset/Ok, got " <> show other) + other -> expectationFailure ("expected one rejection span, got " <> show (length other)) + + it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let okId = OutboxId outboxUuid1 + failId = OutboxId outboxUuid2 + rejectId = OutboxId outboxUuid3 + okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing + failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing + rejectEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-reject" & #key .~ Nothing + rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "not routed")) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx okId okEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx failId failEvent) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (enqueueIntegrationEventTx rejectId rejectEvent) + let publish row + | row ^. #outboxId == okId = pure PublishSucceeded + | row ^. #outboxId == rejectId = pure (PublishRejected rejection) + | otherwise = pure (PublishFailed "broker down") + retryPassOpts = + defaultPublishOptions + & #batchSize + .~ 10 + & #maxAttempts + .~ 5 + & #backoff + .~ ConstantBackoff 0 + & #orderingPolicy + .~ BestEffort + deadPassOpts = retryPassOpts & #maxAttempts .~ 1 + -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries. + Right summary1 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics)) + summary1 ^. #published `shouldBe` 1 + summary1 ^. #rejected `shouldBe` 1 + summary1 ^. #retried `shouldBe` 1 + -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies. + Right summary2 <- + Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics)) + summary2 ^. #dead `shouldBe` 1 + -- Flush so the in-memory exporter receives the aggregates. + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + -- Counters are cumulative across both passes. + lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.rejected" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1) + -- Publish passes no longer run the backlog COUNT(*) on the hot path. + lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing + + Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + + describe "Keiro.Inbox delegated contracts" $ do + it "computes the existing dedupe key and runs without a Store interpreter" $ do + observed <- newIORef Nothing + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-no-store" & #source .~ "ordering" + result <- + runEff $ + runInboxDelegated Nothing PreferIntegrationMessageId event Nothing $ \dedupe delivered -> do + liftIO (writeIORef observed (Just (dedupe, delivered ^. #source))) + pure (DelegatedFresh (42 :: Int)) + result `shouldBe` Right (InboxProcessed 42) + readIORef observed `shouldReturn` Just ("delegated-no-store", "ordering") + + it "rejects an invalid policy before invoking the delegated handler" $ do + invoked <- newIORef False + let event = sampleIntegrationEnvelope + result <- + runEff $ + runInboxDelegated Nothing (CustomDedupeKey "") event Nothing $ \_ _ -> do + liftIO (writeIORef invoked True) + pure (DelegatedFresh ()) + result `shouldBe` Left (DedupePolicyUnsatisfied (CustomDedupeKey "")) + readIORef invoked `shouldReturn` False + + it "validates retry contexts and stops after the caller-owned ceiling" $ do + mkDelegatedRetryContext 0 1 `shouldBe` Left "delegated retry ceiling must be positive" + mkDelegatedRetryContext 3 0 `shouldBe` Left "delegated retry attempt must be positive" + context3 <- shouldBeRight (mkDelegatedRetryContext 3 3) + context4 <- shouldBeRight (mkDelegatedRetryContext 3 4) + invoked <- newIORef (0 :: Int) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry" + handler _ _ = do + liftIO (modifyIORef' invoked (+ 1)) + pure (DelegatedFresh ("ok" :: Text)) + atCeiling <- runEff (runInboxDelegatedWithRetries Nothing context3 PreferIntegrationMessageId event Nothing handler) + aboveCeiling <- runEff (runInboxDelegatedWithRetries Nothing context4 PreferIntegrationMessageId event Nothing handler) + atCeiling `shouldBe` Right (InboxProcessed "ok") + aboveCeiling `shouldBe` Right (InboxPreviouslyFailed Nothing) + readIORef invoked `shouldReturn` 1 + + it "reports the current retry attempt when a synchronous handler exception occurs" $ do + retryContext <- shouldBeRight (mkDelegatedRetryContext 3 2) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry-failure" + handler _ _ = liftIO (throwIO (userError "delegated exploded")) + result <- runEff (runInboxDelegatedWithRetries Nothing retryContext PreferIntegrationMessageId event Nothing handler) + case result of + Right (InboxHandlerFailed reason 2) -> Text.isInfixOf "delegated exploded" reason `shouldBe` True + other -> expectationFailure ("expected delegated attempt failure, got " <> show (void other)) + + it "applies attempts 1 through 4 exactly at a ceiling of 3" $ do + contexts <- traverse (shouldBeRight . mkDelegatedRetryContext 3) [1, 2, 3, 4] + invocations <- newIORef (0 :: Int) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry-ladder" + failing _ _ = do + liftIO (modifyIORef' invocations (+ 1)) + liftIO (throwIO (userError "retry ladder failure")) + pure (DelegatedFresh ()) + succeeding _ _ = do + liftIO (modifyIORef' invocations (+ 1)) + pure (DelegatedFresh ()) + forbidden _ _ = do + liftIO (modifyIORef' invocations (+ 1)) + pure (DelegatedFresh ()) + case contexts of + [attempt1, attempt2, attempt3, attempt4] -> do + first <- runEff (runInboxDelegatedWithRetries Nothing attempt1 PreferIntegrationMessageId event Nothing failing) + second <- runEff (runInboxDelegatedWithRetries Nothing attempt2 PreferIntegrationMessageId event Nothing failing) + third <- runEff (runInboxDelegatedWithRetries Nothing attempt3 PreferIntegrationMessageId event Nothing succeeding) + fourth <- runEff (runInboxDelegatedWithRetries Nothing attempt4 PreferIntegrationMessageId event Nothing forbidden) + first `shouldSatisfy` \case Right (InboxHandlerFailed _ 1) -> True; _ -> False + second `shouldSatisfy` \case Right (InboxHandlerFailed _ 2) -> True; _ -> False + third `shouldBe` Right (InboxProcessed ()) + fourth `shouldBe` Right (InboxPreviouslyFailed Nothing) + readIORef invocations `shouldReturn` 3 + other -> expectationFailure ("unexpected retry contexts: " <> show other) + + it "records failed and poisoned metrics on a failing ceiling attempt" $ do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + retryContext <- shouldBeRight (mkDelegatedRetryContext 3 3) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-poison-metrics" + handler _ _ = do + liftIO (throwIO (userError "terminal delegated failure")) + pure (DelegatedFresh ()) + result <- runEff (runInboxDelegatedWithRetries (Just metrics) retryContext PreferIntegrationMessageId event Nothing handler) + result `shouldSatisfy` \case Right (InboxHandlerFailed _ 3) -> True; _ -> False + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.inbox.failed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.poisoned" scalars `shouldBe` Just (IntNumber 1) + + it "retries a batch identity after failure and suppresses it only after success" $ do + invocations <- newIORef (0 :: Int) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-batch-retry" & #source .~ "source-a" + handler _ _ = do + current <- liftIO (atomicModifyIORef' invocations (\n -> (n + 1, n))) + when (current == 0) (liftIO (throwIO (userError "first attempt failed"))) + pure (DelegatedFresh ()) + results <- + runEff $ + runInboxDelegatedBatch + Nothing + PreferIntegrationMessageId + [(event, Nothing), (event, Nothing), (event, Nothing)] + handler + case results of + [Right (InboxHandlerFailed reason 1), Right (InboxProcessed ()), Right InboxDuplicate] -> + Text.isInfixOf "first attempt failed" reason `shouldBe` True + other -> expectationFailure ("unexpected delegated batch results: " <> show other) + readIORef invocations `shouldReturn` 2 + + it "scopes in-batch suppression by integration source" $ do + invocations <- newIORef ([] :: [Text]) + let first = sampleIntegrationEnvelope & #messageId .~ "shared" & #source .~ "source-a" + second = sampleIntegrationEnvelope & #messageId .~ "shared" & #source .~ "source-b" + handler _ event = do + liftIO (modifyIORef' invocations (<> [event ^. #source])) + pure (DelegatedFresh ()) + results <- + runEff $ + runInboxDelegatedBatch Nothing PreferIntegrationMessageId [(first, Nothing), (second, Nothing)] handler + results `shouldBe` [Right (InboxProcessed ()), Right (InboxProcessed ())] + readIORef invocations `shouldReturn` ["source-a", "source-b"] + + it "keeps invalid and poison deliveries isolated from later batch items" $ do + invoked <- newIORef ([] :: [Text]) + let invalid = sampleIntegrationEnvelope & #messageId .~ "" & #source .~ "invalid-source" + poison = sampleIntegrationEnvelope & #messageId .~ "poison" & #source .~ "poison-source" + healthy = sampleIntegrationEnvelope & #messageId .~ "healthy" & #source .~ "healthy-source" + handler _ event = do + liftIO (modifyIORef' invoked (<> [event ^. #source])) + when (event ^. #source == "poison-source") (liftIO (throwIO (userError "poison item"))) + pure (DelegatedFresh ()) + results <- + runEff $ + runInboxDelegatedBatch + Nothing + PreferIntegrationMessageId + [(invalid, Nothing), (poison, Nothing), (healthy, Nothing)] + handler + case results of + [ Left (DedupePolicyUnsatisfied PreferIntegrationMessageId), + Right (InboxHandlerFailed reason 1), + Right (InboxProcessed ()) + ] -> Text.isInfixOf "poison item" reason `shouldBe` True + other -> expectationFailure ("unexpected isolated batch results: " <> show other) + readIORef invoked `shouldReturn` ["poison-source", "healthy-source"] + + it "propagates async cancellation from a synchronized delegated batch handler" $ do + entered <- newEmptyMVar + release <- newEmptyMVar + completed <- newEmptyMVar + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-cancel" + handler _ _ = liftIO (putMVar entered () >> takeMVar release) >> pure (DelegatedFresh ()) + worker <- + forkIO $ do + outcome <- + try @AsyncException $ + runEff (runInboxDelegatedBatch Nothing PreferIntegrationMessageId [(event, Nothing)] handler) + putMVar completed outcome + takeMVar entered + killThread worker + takeMVar completed `shouldReturn` Left ThreadKilled + + describe "Keiro.Inbox.Delegated pure adapters" $ do + it "pins ASCII, Unicode, empty-field, and delimiter identity vectors" $ do + let base = delegatedEventId "consumer" "source" "message" (StreamName "counter-1") "apply" + base `shouldBe` EventId (uuidLiteral "8c9d74d0-1b27-5ef8-aa0c-3b37ed8ce8a8") + delegatedEventId "消費者" "源" "鍵" (StreamName "対象-1") "適用" + `shouldBe` EventId (uuidLiteral "e63f2f93-c519-5e9b-95e7-a233a1c32ae6") + delegatedEventId "" "a:b" "c" (StreamName "") ":" + `shouldBe` EventId (uuidLiteral "9ffa9002-be85-5713-8705-38c47a9731b4") + base `shouldNotBe` delegatedEventId "consumer:" "source" "message" (StreamName "counter-1") "apply" + base `shouldNotBe` delegatedEventId "consumer" ":source" "message" (StreamName "counter-1") "apply" + base `shouldNotBe` delegatedEventId "consumer" "source" "message" (StreamName "counter-2") "apply" + + it "maps every process-manager command result without acknowledging failures or no-ops" $ do + let targetName = StreamName "counter-delegated-pm" + target = stream "counter-delegated-pm" :: Stream CounterEventStream + appended n = + CommandResult + { target, + streamVersion = StreamVersion (fromIntegral n), + globalPosition = if n > 0 then Just (GlobalPosition (fromIntegral n)) else Nothing, + eventsAppended = n + } + marker = EventId sampleUuid + delegatedFromPMCommand targetName (PMCommandAppended (appended 2)) + `shouldBe` Right (DelegatedFresh (appended 2)) + delegatedFromPMCommand targetName (PMCommandDuplicate marker) + `shouldBe` Right DelegatedDuplicate + delegatedFromPMCommand targetName (PMCommandAppended (appended 0)) + `shouldBe` Left (DelegatedCommandWithoutReceipt targetName) + delegatedFromPMCommand targetName (PMCommandFailed targetName CommandRejected) + `shouldBe` Left (DelegatedCommandFailed targetName CommandRejected) + + describe "Keiro.Inbox delegated" $ around (withFreshResourceStore fixture) $ do + it "bypasses the inbox and preflights a one-shot command before invalid dispatch" $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + callbackInvocations <- newIORef (0 :: Int) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-command-once" & #source .~ "delegated-source" + targetName = StreamName "delegated-once-1" + target = stream "delegated-once-1" :: Stream DelegatedOneShotEventStream + marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-order" + handler dedupe _ = do + outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared -> do + liftIO (modifyIORef' callbackInvocations (+ 1)) + fmap (fmap Prelude.fst) $ + runCommandWithSql + prepared + delegatedOneShotEventStream + target + (Add 1) + (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt) + case outcome of + Left err -> liftIO (throwIO (userError (show err))) + Right delegated -> pure delegated + first <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + case first of + Right (Right (InboxProcessed commandResult)) -> commandResult ^. #eventsAppended `shouldBe` 1 + other -> expectationFailure ("expected a fresh delegated command, got " <> show other) + + -- Hydrating and dispatching the command now would reject in the terminal + -- state. Delegated replay must find the marker before reaching that path. + directReplay <- runner (runCommand defaultRunCommandOptions delegatedOneShotEventStream target (Add 1)) + directReplay `shouldBe` Right (Left CommandRejected) + second <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + second `shouldBe` Right (Right InboxDuplicate) + readIORef callbackInvocations `shouldReturn` 1 + + Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10) + Vector.length stored `shouldBe` 1 + stored Vector.! 0 ^. #eventId `shouldBe` marker + Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)) + counterRows `shouldBe` 1 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-source") + inboxRows `shouldBe` [] + + it "recovers a lost acknowledgement for an atomic multi-event command" $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-command-multi" & #source .~ "delegated-multi-source" + targetName = StreamName "counter-delegated-multi" + target = stream "counter-delegated-multi" :: Stream CounterEventStream + marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-multi" + handler dedupe _ = do + outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared -> + fmap (fmap Prelude.fst) $ + runCommandWithSql + prepared + multiCounterEventStream + target + (Add 2) + (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt) + case outcome of + Left err -> liftIO (throwIO (userError (show err))) + Right delegated -> pure delegated + -- Discard the first successful return to simulate a crash before source + -- acknowledgement, then redeliver the same envelope. + _ <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + redelivery <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + redelivery `shouldBe` Right (Right InboxDuplicate) + Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10) + Vector.length stored `shouldBe` 2 + stored Vector.! 0 ^. #eventId `shouldBe` marker + Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)) + counterRows `shouldBe` 1 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-multi-source") + inboxRows `shouldBe` [] + + it "rejects zero-event commands and unconfirmed duplicate errors" $ \(_storeHandle, StoreRunner runner) -> do + let targetName = StreamName "counter-delegated-errors" + target = stream "counter-delegated-errors" :: Stream CounterEventStream + marker = EventId sampleUuid + other = EventId sampleUuid2 + noOp prepared = runCommand prepared noOpCounterEventStream target (Add 1) + zero <- runner (delegatedCommand defaultRunCommandOptions targetName marker noOp) + zero `shouldBe` Right (Left (DelegatedCommandWithoutReceipt targetName)) + mismatched <- + runner $ + delegatedCommand defaultRunCommandOptions targetName marker $ \_ -> + pure (Left (StoreFailed (Store.DuplicateEvent (Just other)))) + mismatched `shouldBe` Right (Left (DelegatedCommandFailed targetName (StoreFailed (Store.DuplicateEvent (Just other))))) + missing <- + runner $ + delegatedCommand defaultRunCommandOptions targetName marker $ \_ -> + pure (Left (StoreFailed (Store.DuplicateEvent Nothing))) + missing `shouldBe` Right (Left (DelegatedCommandFailed targetName (StoreFailed (Store.DuplicateEvent Nothing)))) + + it "converges a concurrent delivery race to one event batch and SQL effect" $ \(storeHandle, StoreRunner runner) -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + arrivals <- newMVar (0 :: Int) + release <- newEmptyMVar + firstDone <- newEmptyMVar + secondDone <- newEmptyMVar + retryContext <- shouldBeRight (mkDelegatedRetryContext 3 1) + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-race" & #source .~ "delegated-race-source" + targetName = StreamName "counter-delegated-race" + target = stream "counter-delegated-race" :: Stream CounterEventStream + marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-race" + awaitPeer = do + arrived <- modifyMVar arrivals $ \count -> + let next = count + 1 + in pure (next, next) + when (arrived == 2) (putMVar release ()) + readMVar release + options = + defaultRunCommandOptions + & #retryLimit + .~ 0 + & #beforeAppend + .~ awaitPeer + handler dedupe _ = do + outcome <- delegatedCommand options targetName marker $ \prepared -> + fmap (fmap Prelude.fst) $ + runCommandWithSql + prepared + counterEventStream + target + (Add 1) + (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt) + case outcome of + Left err -> liftIO (throwIO (userError (show err))) + Right delegated -> pure delegated + runOne destination = + runner + (runInboxDelegatedWithRetries Nothing retryContext PreferIntegrationMessageId event Nothing handler) + >>= putMVar destination + _ <- forkIO (runOne firstDone) + _ <- forkIO (runOne secondDone) + outcomes <- traverse takeMVar [firstDone, secondDone] + let processed = + Prelude.length + [ () + | Right (Right (InboxProcessed {})) <- outcomes + ] + safeLosers = + Prelude.length + [ () + | Right (Right InboxDuplicate) <- outcomes + ] + + Prelude.length + [ () + | Right (Right (InboxHandlerFailed {})) <- outcomes + ] + (processed, safeLosers) `shouldBe` (1, 1) + + -- A retry after either allowed loser classification observes the winner. + replay <- + runner $ + runInboxDelegated Nothing PreferIntegrationMessageId event Nothing $ \_ _ -> do + outcome <- delegatedCommand defaultRunCommandOptions targetName marker (\_ -> error "race replay dispatched") + case outcome of + Left err -> liftIO (throwIO (userError (show err))) + Right delegated -> pure delegated + replay `shouldBe` Right (Right InboxDuplicate) + Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10) + Vector.length stored `shouldBe` 1 + Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)) + counterRows `shouldBe` 1 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-race-source") + inboxRows `shouldBe` [] + + it "does not acknowledge a globally colliding marker from another stream" $ \(storeHandle, StoreRunner runner) -> do + let marker = EventId sampleUuid3 + foreignName = StreamName "counter-delegated-foreign" + targetName = StreamName "counter-delegated-collision" + target = stream "counter-delegated-collision" :: Stream CounterEventStream + appendCounterEventWithId storeHandle foreignName marker (CounterAdded 9) + outcome <- + runner $ + delegatedCommand defaultRunCommandOptions targetName marker $ \prepared -> + runCommand prepared counterEventStream target (Add 1) + case outcome of + Right (Left (DelegatedCommandFailed failedTarget (StoreFailed Store.DuplicateEvent {}))) -> + failedTarget `shouldBe` targetName + other -> expectationFailure ("expected an unconfirmed foreign collision, got " <> show other) + Right targetEvents <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10) + Right foreignEvents <- Store.runStoreIO storeHandle (Store.readStreamForward foreignName (StreamVersion 0) 10) + Vector.length targetEvents `shouldBe` 0 + Vector.length foreignEvents `shouldBe` 1 + + describe "Keiro.Inbox delegated access control" + $ around + ( withFreshResourceStorePrepared + fixture + prepareDelegatedDeniedInboxRole + (\settings -> settings & #connString %~ (<> " user=delegated_inbox_denied")) + ) + $ do + it "runs with downstream privileges while the inbox table is denied" $ \(storeHandle, StoreRunner runner) -> do + denied <- Store.runStoreIO storeHandle (listInbox "delegated-denied-source") + denied `shouldSatisfy` \case + Left _ -> True + Right _ -> False + let event = sampleIntegrationEnvelope & #messageId .~ "delegated-denied" & #source .~ "delegated-denied-source" + targetName = StreamName "counter-delegated-denied" + target = stream "counter-delegated-denied" :: Stream CounterEventStream + marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-denied" + handler dedupe _ = do + outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared -> + fmap (fmap Prelude.fst) $ + runCommandWithSql + prepared + counterEventStream + target + (Add 1) + (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt) + case outcome of + Left err -> liftIO (throwIO (userError (show err))) + Right delegated -> pure delegated + first <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + first `shouldSatisfy` \case + Right (Right (InboxProcessed commandResult)) -> commandResult ^. #eventsAppended == 1 + _ -> False + replay <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler) + replay `shouldBe` Right (Right InboxDuplicate) + Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10) + Vector.length stored `shouldBe` 1 + Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)) + counterRows `shouldBe` 1 + + describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do + it "runs the handler once and records the row as completed" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-1" + & #source + .~ "ordering" + handler ev = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case result1 of + Right (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected InboxProcessed, got " <> show other) + Right rowCount1 <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount1 `shouldBe` 1 + Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1") + inboxRow ^. #status `shouldBe` InboxCompleted + inboxRow ^. #completedAt `shouldSatisfy` isJust + + it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-dup" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + -- First delivery runs the handler: processed. + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + -- Second delivery of the same (source, message_id): duplicate. + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler + result2 `shouldBe` Right InboxDuplicate + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing + Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right () + _ <- forceFlushMeterProvider provider Nothing + sampled <- readIORef metricsRef + let sampledScalars = flattenScalarPoints sampled + lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0) + -- The handler ran exactly once (the duplicate path does not re-run it). + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let shared = sampleIntegrationEnvelope & #source .~ "ordering" + first = shared & #messageId .~ "republish-1" + second = shared & #messageId .~ "republish-2" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler + result2 `shouldBe` Right InboxDuplicate + + it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = sampleIntegrationEnvelope & #source .~ "ordering" + kafka = KafkaDeliveryRef "billing.orders.v1" 0 17 + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Right InboxDuplicate) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler + Right (Just row) <- + Store.runStoreIO storeHandle $ + lookupInbox "ordering" "billing.orders.v1:0:17" + row ^. #status `shouldBe` InboxCompleted + + it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #source + .~ "ordering" + & #sourceEventId + .~ Nothing + & #sourceGlobalPosition + .~ Nothing + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ()) + result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity) + + it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-rollback" + & #source + .~ "ordering" + handler _ = do + Tx.condemn + pure () + _ <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback") + row `shouldBe` Nothing + + it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-throw-plain" + & #source + .~ "ordering" + handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction () + thrown <- + try $ + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + case thrown of + Left (_ :: SomeException) -> pure () + Right other -> expectationFailure ("expected handler exception, got " <> show (void other)) + Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain") + row `shouldBe` Nothing + + it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-public-failed" + & #source + .~ "ordering" + handler _ = do + markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt) + pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #lastError `shouldBe` Just "operator failed" + + it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-1" + & #source + .~ "ordering" + handler _ = (pure $! error "inbox exploded") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err attempts) -> do + Text.isInfixOf "inbox exploded" err `shouldBe` True + attempts `shouldBe` 1 + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded") + + it "a transient poison message succeeds on retry" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-transient" + & #source + .~ "ordering" + failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction () + succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce + case result1 of + Right (InboxHandlerFailed _ 1) -> pure () + other -> expectationFailure ("expected first failed attempt, got " <> show other) + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding + result2 `shouldBe` Right (InboxProcessed ()) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient") + row ^. #status `shouldBe` InboxCompleted + row ^. #attemptCount `shouldBe` 1 + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-poison-dead" + & #source + .~ "ordering" + handler _ = (pure $! error "always broken") :: Tx.Transaction () + Right result1 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result2 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + Right result3 <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler + case (result1, result2, result3) of + ( Right (InboxHandlerFailed _ 1), + Right (InboxHandlerFailed _ 2), + Right (InboxPreviouslyFailed _) + ) -> pure () + other -> expectationFailure ("unexpected poison lifecycle: " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 2 + + it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-msg-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 50 :: Int] + ] + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + results `shouldBe` replicate 50 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 50 + Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering") + length inboxRows `shouldBe` 50 + all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True + + it "deduplicates repeated messages within one batch" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler + results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler throws" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-poison-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 5 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-poison-3" = + (pure $! error "batch poison") :: Tx.Transaction () + | otherwise = + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + case results of + [ Right (InboxProcessed ()), + Right (InboxProcessed ()), + Right (InboxHandlerFailed err 1), + Right (InboxProcessed ()), + Right (InboxProcessed ()) + ] -> + Text.isInfixOf "batch poison" err `shouldBe` True + other -> expectationFailure ("unexpected batch fallback results: " <> show other) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 4 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3") + row ^. #status `shouldBe` InboxFailed + row ^. #attemptCount `shouldBe` 1 + row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison") + + it "reports duplicates across batch calls" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-batch-existing-dup" + & #source + .~ "batch-ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right first <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + first `shouldBe` [Right (InboxProcessed ())] + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler + second `shouldBe` [Right InboxDuplicate] + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let events = + [ sampleIntegrationEnvelope + & #messageId + .~ ("inbox-batch-condemn-" <> Text.pack (show n)) + & #source + .~ "batch-ordering" + | n <- [1 .. 3 :: Int] + ] + handler ev + | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn + | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right results <- + Store.runStoreIO storeHandle $ + runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler + -- The condemned single-message retry reports processed by the + -- documented single-path contract; what matters is that the + -- innocent batch mates actually committed. + results `shouldBe` replicate 3 (Right (InboxProcessed ())) + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 2 + Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1") + Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3") + mate1 ^. #status `shouldBe` InboxCompleted + mate3 ^. #status `shouldBe` InboxCompleted + Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2") + condemned `shouldBe` Nothing + + it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-legacy-processing" + & #source + .~ "ordering" + handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')" + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + result `shouldBe` Right InboxInProgress + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing") + row ^. #status `shouldBe` InboxProcessing + + it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)") + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-race-dup" + & #source + .~ "ordering" + slowHandler ev = do + Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + Tx.sql "SELECT pg_sleep(1.5)" + fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt + firstDone <- newEmptyMVar + _ <- forkIO $ do + first <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler + putMVar firstDone first + -- Let the slow worker insert its uncommitted row, then race the + -- same dedupe key: the second insert must block on the unique + -- constraint until the first commits, then classify as duplicate. + threadDelay 400000 + Right second <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler + Right first <- takeMVar firstDone + first `shouldBe` Right (InboxProcessed ()) + second `shouldBe` Right InboxDuplicate + Right rowCount <- + Store.runStoreIO storeHandle $ + Store.runTransaction (Tx.statement () inboxTestCounterCountStmt) + rowCount `shouldBe` 1 + + it "can persist only dedupe columns for successful rows" $ \storeHandle -> do + let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42 + event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-success" + & #source + .~ "ordering" + & #payloadBytes + .~ "full success payload" + & #attributes + ?~ object ["source" Aeson..= ("slim-test" :: Text)] + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success") + row ^. #event . #payloadBytes `shouldBe` "" + row ^. #event . #attributes `shouldBe` Nothing + row ^. #event . #traceContext `shouldBe` Nothing + row ^. #event . #schemaReference `shouldBe` Nothing + row ^. #event . #messageId `shouldBe` "inbox-slim-success" + row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId + row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition + row ^. #event . #causationId `shouldBe` event ^. #causationId + row ^. #event . #correlationId `shouldBe` event ^. #correlationId + row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt + row ^. #kafka `shouldBe` Just kafka + Right redelivery <- + Store.runStoreIO storeHandle $ + runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler + redelivery `shouldBe` Right InboxDuplicate + + it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-slim-failed" + & #source + .~ "ordering" + & #payloadBytes + .~ "full failed payload" + & #attributes + ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)] + handler _ = (pure $! error "slim failure") :: Tx.Transaction () + Right result <- + Store.runStoreIO storeHandle $ + runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler + case result of + Right (InboxHandlerFailed err 1) -> + Text.isInfixOf "slim failure" err `shouldBe` True + other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other) + Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed") + row ^. #status `shouldBe` InboxFailed + row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes + row ^. #event . #attributes `shouldBe` event ^. #attributes + row ^. #event . #traceContext `shouldBe` event ^. #traceContext + row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference + + it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do + let event = + sampleIntegrationEnvelope + & #messageId + .~ "inbox-msg-gc" + & #source + .~ "ordering" + handler _ = pure () + Right (Right (InboxProcessed ())) <- + Store.runStoreIO storeHandle $ + runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler + -- Backdate the row so it falls outside the retention window. + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql + "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'" + now <- getCurrentTime + Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now) + deleted `shouldBe` 1 + Right rows <- Store.runStoreIO storeHandle (listInbox "ordering") + rows `shouldBe` [] + + describe "Keiro.Inbox.Kafka" $ do + it "reconstructs an integration event from headers and payload" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, kafkaRef) -> do + rebuilt ^. #messageId `shouldBe` envelope ^. #messageId + rebuilt ^. #source `shouldBe` envelope ^. #source + rebuilt ^. #destination `shouldBe` envelope ^. #destination + rebuilt ^. #eventType `shouldBe` envelope ^. #eventType + rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion + rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId + rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition + rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes + rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt + rebuilt ^. #attributes `shouldBe` envelope ^. #attributes + kafkaRef ^. #topic `shouldBe` "billing.orders.v1" + kafkaRef ^. #partition `shouldBe` 2 + kafkaRef ^. #offset `shouldBe` 113 + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "falls back to receivedAt when the occurredAt header is absent" $ do + let envelope = sampleIntegrationEnvelope + receivedAt = addUTCTime 60 (envelope ^. #occurredAt) + headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt + } + case InboxKafka.integrationEventFromKafka record of + Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt + Left err -> expectationFailure ("expected Right, got Left " <> show err) + + it "rejects malformed occurredAt headers" $ do + let envelope = sampleIntegrationEnvelope + headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 2, + offset = 113, + key = Just "order-123", + payload = envelope ^. #payloadBytes, + headers, + receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time") + + it "reports MissingHeader for an essential header" $ do + let envelope = sampleIntegrationEnvelope + headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope) + record = + InboxKafka.KafkaInboundRecord + { topic = "billing.orders.v1", + partition = 0, + offset = 0, + key = Nothing, + payload = envelope ^. #payloadBytes, + headers, + receivedAt = envelope ^. #occurredAt + } + InboxKafka.integrationEventFromKafka record + `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id") + + it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "keiro-test" tracerOptions + -- Clear the baked-in TraceContext on the sample so the only + -- `traceparent` on the wire comes from the active producer + -- span (via `injectTraceContext`). + envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing + producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope + producerHeadersText <- + Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do + let baseHeaders = + [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers] + Telemetry.injectTraceContext baseHeaders + -- Build the inbound record the consumer would receive and open the + -- consumer span around a no-op body. + now <- getCurrentTime + let inbound = + InboxKafka.KafkaInboundRecord + { topic = envelope ^. #destination, + partition = 7, + offset = 42, + key = envelope ^. #key, + payload = envelope ^. #payloadBytes, + headers = producerHeadersText, + receivedAt = now + } + Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ -> + pure () + _ <- shutdownTracerProvider provider Nothing + spans <- traverse captureSpan =<< readIORef spansRef + length spans `shouldBe` 2 + let findByName needle = case [s | s <- spans, csName s == needle] of + (s : _) -> s + [] -> error ("no span captured with name=" <> Text.unpack needle) + producerSp = findByName ("send " <> envelope ^. #destination) + consumerSp = findByName ("process " <> envelope ^. #destination) + -- Same trace id end-to-end (cross-process parenting). + traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp) + -- Consumer's parent is the producer span. + case csParent consumerSp of + Nothing -> expectationFailure "consumer span has no parent" + Just parent -> do + parentCtx <- getSpanContext parent + spanId parentCtx `shouldBe` spanId (csContext producerSp) + -- Consumer span carries the expected attributes. + show (csKind consumerSp) `shouldBe` "Consumer" + textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka" + textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process" + textAttr (csAttributes consumerSp) "messaging.destination.name" + `shouldBe` Just (envelope ^. #destination) + textAttr (csAttributes consumerSp) "messaging.destination.partition.id" + `shouldBe` Just "7" + textAttr (csAttributes consumerSp) "messaging.consumer.group.name" + `shouldBe` Just "billing-cg" + textAttr (csAttributes consumerSp) "messaging.message.id" + `shouldBe` Just (envelope ^. #messageId) + + describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do + it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + -- Ordering side: enqueue an outbox row representing a published event. + let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa" + oid = OutboxId outboxUuid1 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent) + -- Run the publisher worker: push records to the in-process topic. + Right pubSummary1 <- + Store.runStoreIO ordering $ + publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing + pubSummary1 ^. #published `shouldBe` 1 + -- Billing side: consume from the topic. + records1 <- drainKafkaTopic topic + record1 <- case records1 of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed1 <- + Store.runStoreIO billing $ + consumeAndApply record1 billingReactionHandler + consumed1 `shouldBe` ConsumeApplied (InboxProcessed ()) + Right rowCount1 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount1 `shouldBe` 1 + + -- Simulate Kafka redelivery: pretend the same Kafka record was + -- delivered again at a different offset. The producer also retries + -- (the outbox flips back to pending and the worker republishes). + let redelivered = redeliverWithDifferentOffset record1 + Right consumed2 <- + Store.runStoreIO billing $ + consumeAndApply redelivered billingReactionHandler + consumed2 `shouldBe` ConsumeApplied InboxDuplicate + Right rowCount2 <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt) + rowCount2 `shouldBe` 1 + + it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)") + topic <- newKafkaTopic + -- Two events for the same order key. + let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1" + cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2" + submittedId = OutboxId outboxUuid1 + cancelledId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv) + -- Run-claiming lets a same-key contiguous run drain in one pass. + let drainOnce = + publishClaimedOutbox + (perRow (kafkaTopicPublish topic)) + (defaultPublishOptions & #backoff .~ ConstantBackoff 0) + Nothing + Right s1 <- Store.runStoreIO ordering drainOnce + Right s2 <- Store.runStoreIO ordering drainOnce + (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2 + records <- drainKafkaTopic topic + length records `shouldBe` 2 + -- Apply both records to billing in delivery order. + for_ records $ \record -> do + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record (loggingReactionHandler "billing") + case consumed of + ConsumeApplied (InboxProcessed ()) -> pure () + other -> expectationFailure ("expected processed, got " <> show other) + Right events <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.statement () billingEventLogStmt) + events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")] + + it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do + Right () <- + Store.runStoreIO billing $ + Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)") + topic <- newKafkaTopic + let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1" + cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2" + firstId = OutboxId outboxUuid1 + secondId = OutboxId outboxUuid2 + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv) + Right () <- + Store.runStoreIO ordering $ + Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv) + -- Failing publish for the first row, success for any other. + let publish row + | row ^. #outboxId == firstId = + pure (PublishFailed "simulated broker reject") + | otherwise = do + kafkaTopicAccept topic row + pure PublishSucceeded + deadOpts = + defaultPublishOptions + & #batchSize + .~ 1 + & #backoff + .~ ConstantBackoff 0 + & #maxAttempts + .~ 2 + -- This test drives the pre-M3 sequential failure/dead-letter path + -- with one-row batches. M3 adds suffix skipping for larger claimed + -- same-key runs. + -- First pass: the first row attempts once and fails; the second is + -- outside the one-row claim window. + Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass1 ^. #retried `shouldBe` 1 + pass1 ^. #published `shouldBe` 0 + -- Second pass crosses maxAttempts and dead-letters the first row. + Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass2 ^. #dead `shouldBe` 1 + Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId) + firstRow ^. #status `shouldBe` OutboxDead + -- With the first row dead, the second becomes claimable and publishes. + Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing) + pass3 ^. #published `shouldBe` 1 + Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId) + secondRow ^. #status `shouldBe` OutboxSent + -- Billing only sees the second event. + records <- drainKafkaTopic topic + record <- case records of + [r] -> pure r + other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable" + Right consumed <- + Store.runStoreIO billing $ + consumeAndApply record billingReactionHandler + consumed `shouldBe` ConsumeApplied (InboxProcessed ()) + + describe "Keiro.Integration.Event" $ do + it "round-trips a JSON envelope through encode and decode" $ do + let envelope = sampleIntegrationEnvelope + payload = OrderSubmittedPayload "order-123" 5 + encoded = encodeJsonIntegrationEvent envelope payload + decodeJsonIntegrationEvent encoded `shouldBe` Right payload + + it "preserves identity and routing through encode" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + encoded ^. #messageId `shouldBe` envelope ^. #messageId + encoded ^. #source `shouldBe` "ordering" + encoded ^. #destination `shouldBe` "billing.orders.v1" + encoded ^. #key `shouldBe` Just "order-123" + encoded ^. #eventType `shouldBe` "OrderSubmitted" + encoded ^. #schemaVersion `shouldBe` 1 + encoded ^. #contentType `shouldBe` ApplicationJson + + it "emits the canonical wire headers" $ do + let envelope = sampleIntegrationEnvelope + headers = integrationHeaders envelope + Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId) + Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1" + Prelude.lookup headerContentType headers `shouldBe` Just "application/json" + Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted" + Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003" + Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42" + Prelude.lookup headerTraceParent headers + `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + + it "preserves a different content type without claiming JSON" $ do + let envelope = + sampleIntegrationEnvelope + & #contentType + .~ OtherContentType "application/vnd.apache.avro.binary" + & #payloadBytes + .~ "\x00\x01\x02" + headers = integrationHeaders envelope + Prelude.lookup headerContentType headers + `shouldBe` Just "application/vnd.apache.avro.binary" + decodeJsonIntegrationEvent envelope + `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") :: + Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload + ) + + it "reports malformed JSON payloads as decode errors instead of throwing" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{not-json" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.MalformedPayload _) -> pure () + other -> expectationFailure ("expected MalformedPayload, got " <> show other) + + it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do + let envelope = + sampleIntegrationEnvelope + & #payloadBytes + .~ "{\"orderId\":\"order-123\"}" + case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of + Left (IntegrationEvent.DecodeFailed _) -> pure () + other -> expectationFailure ("expected DecodeFailed, got " <> show other) + + it "parses content-type headers back to the canonical type" $ do + parseContentType "application/json" `shouldBe` ApplicationJson + parseContentType "Application/JSON" `shouldBe` ApplicationJson + parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson + parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson + parseContentType "application/vnd.apache.avro.binary" + `shouldBe` OtherContentType "application/vnd.apache.avro.binary" + + it "preserves the payload bytes through integrationPayload" $ do + let envelope = sampleIntegrationEnvelope + encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5) + integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes) + + describe "Keiro.Telemetry" $ do + it "is a pass-through under a noop (Nothing) tracer" $ do + counter <- newIORef (0 :: Int) + let envelope = sampleIntegrationEnvelope + record = OutboxKafka.integrationEventToKafkaRecord envelope + result <- + Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do + atomicModifyIORef' counter (\n -> (n + 1, ())) + pure (mSpan, "ok" :: Text) + callsAfter <- readIORef counter + callsAfter `shouldBe` (1 :: Int) + snd result `shouldBe` "ok" + fst result `shouldSatisfy` isNothing + + it "re-exports AttributeKeys whose textual payload matches the spec name" $ do + attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type" + attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name" + attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id" + attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name" + attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id" + attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset" + attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name" + attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace" + attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name" + attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name" + attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name" + attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt" + attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended" + attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence" + + it "extracts a TraceContext from a W3C traceparent header pair" $ do + let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + tracestate = "vendor1=value1" + hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)] + Telemetry.traceContextFromHeaders hs + `shouldBe` Just (TraceContext traceparent (Just tracestate)) + + it "returns Nothing when the traceparent header is missing" $ do + Telemetry.traceContextFromHeaders [("content-type", "application/json")] + `shouldBe` Nothing + + it "injectTraceContext is a no-op when no span is active on the thread" $ do + let baseline = [("content-type", "application/json")] + injected <- Telemetry.injectTraceContext baseline + injected `shouldBe` baseline + + it "traceContextFromCurrentSpan returns Nothing outside any span" $ do + tc <- Telemetry.traceContextFromCurrentSpan + tc `shouldBe` Nothing + + describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do + it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "demo" + wid = WorkflowId "demo-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True + _ -> False + + it "replays recorded steps without re-running their side effects" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "replay" + wid = WorkflowId "r-1" + first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + afterFirst <- readIORef counter + afterFirst `shouldBe` 2 + -- A second run with the same id is exactly the crash-restart scenario. + second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + -- The deterministic ids and pre-load gating leave the journal at 3 events. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 3 + + it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "samename" + wid = WorkflowId "s-1" + duplicateStepWorkflow = do + a <- step (StepName "dup") (liftIO (incrementAndRead counter)) + b <- step (StepName "dup") (liftIO (incrementAndRead counter)) + pure (a, b) + result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow + result `shouldBe` Right (Completed (1, 1)) + sideEffects <- readIORef counter + sideEffects `shouldBe` 1 + + it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do + let name = WorkflowName "awaiter" + wid = WorkflowId "a-1" + result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + result `shouldBe` Right Suspended + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 0 + + it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do + let name = WorkflowName "awaiter2" + wid = WorkflowId "a-2" + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + suspended `shouldBe` Right Suspended + -- Simulate a wake source recording the awaited step's resolution. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now) + resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + resumed `shouldBe` Right (Completed 42) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True + _ -> False + + it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do + let name = WorkflowName "duplicate-append" + wid = WorkflowId "da-1" + stepKey = "awk:test" + eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t + now <- getCurrentTime + Right firstId <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondResult <- + Store.runStoreIO storeHandle $ + appendJournalEntryReturningId name wid (eventAt now) + secondId <- case secondResult of + Right value -> pure value + Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable" + secondId `shouldBe` firstId + Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0 + Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do + let name = WorkflowName "journal-race" + wid = WorkflowId "jr-1" + body = + step (StepName "raced") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now) + pure ("loser" :: Text) + outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body + outcome `shouldBe` Right (Completed "winner") + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text) + _ -> False + + it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do + let name = WorkflowName "roundtrip-step" + wid = WorkflowId "rs-1" + body = step (StepName "approx") (pure (Approx 1.7)) + first <- Store.runStoreIO storeHandle $ runWorkflow name wid body + first `shouldBe` Right (Completed (Approx 2.0)) + replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body + replay `shouldBe` Right (Completed (Approx 2.0)) + + it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do + let name = WorkflowName "bad-roundtrip" + wid = WorkflowId "br-1" + body = step (StepName "bad") (pure RejectingRoundTrip) + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "bad" + _ -> False + Store.runStoreIO storeHandle (stepExists name wid 0 "bad") + `shouldReturn` Right True + + -- Discovery is exact. A completed workflow is finished, and a workflow + -- parked on an unresolved await has nothing to do until its wake source + -- resolves — the wake's own append is what makes it discoverable again. + it "discovers a parked workflow only once its awaited step is journaled" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter) + parkedAt <- getCurrentTime + Right whileParked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) + whileParked `shouldBe` [] + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry + (WorkflowName "pending") + (WorkflowId "p-1") + (StepRecorded "awk:wait" (toJSON (7 :: Int)) now) + wokenAt <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + unfinished `shouldBe` [("p-1", "pending")] + + describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do + it "lists workflow instances with filters and stable keyset pages" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "b-2" "beta" 0 Instance.WfFailed (Just "boom") + Instance.upsertInstanceTx "a-2" "alpha" 0 Instance.WfCompleted Nothing + Instance.upsertInstanceTx "b-1" "beta" 0 Instance.WfRunning Nothing + Instance.upsertInstanceTx "a-1" "alpha" 0 Instance.WfFailed (Just "bad") + + let firstPageFilter = + Instance.defaultWorkflowInstanceFilter + { Instance.pageSize = 2 + } + Right firstPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances firstPageFilter + fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) firstPage + `shouldBe` [("alpha", "a-1"), ("alpha", "a-2")] + + let secondPageFilter = + firstPageFilter + { Instance.afterKey = Just ("alpha", "a-2") + } + Right secondPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances secondPageFilter + fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) secondPage + `shouldBe` [("beta", "b-1"), ("beta", "b-2")] + + let failedBetaFilter = + Instance.defaultWorkflowInstanceFilter + { Instance.statuses = Just (Instance.WfFailed :| []), + Instance.workflowName = Just "beta" + } + Right failedBeta <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances failedBetaFilter + fmap (\row -> (row ^. #workflowName, row ^. #workflowId, row ^. #status)) failedBeta + `shouldBe` [("beta", "b-2", Instance.WfFailed)] + + it "cancels active workflows idempotently without minting unknown state" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "operator-cancel" + wid = WorkflowId "operator-cancel-1" + completedName = WorkflowName "operator-completed" + completedId = WorkflowId "operator-completed-1" + Left (_ :: SimulatedCrash) <- + try $ + Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + + Right Instance.WorkflowCancelRecorded <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow name wid + Right Keiro.Workflow.Cancelled <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (threeStep counter) + readIORef counter `shouldReturn` 1 + Right (Instance.WorkflowAlreadyTerminal Instance.WfCancelled) <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow name wid + + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow completedName completedId (demoWorkflow counter) + Right (Instance.WorkflowAlreadyTerminal Instance.WfCompleted) <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow completedName completedId + + Right Instance.WorkflowCancelUnknown <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow (WorkflowName "missing") (WorkflowId "missing-1") + Right Nothing <- + Store.runStoreIO storeHandle $ + Instance.lookupInstance (WorkflowName "missing") (WorkflowId "missing-1") + pure () + + it "cancels suspended and linked-child workflows through supported paths" $ \storeHandle -> do + let suspendedName = WorkflowName "operator-suspended" + suspendedId = WorkflowId "operator-suspended-1" + parentName = WorkflowName "operator-parent" + parentId = WorkflowId "operator-parent-1" + childName = WorkflowName "ship" + childId = WorkflowId "operator-child-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow suspendedName suspendedId neverArmingWorkflow + Right Instance.WorkflowCancelRecorded <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow suspendedName suspendedId + now <- getCurrentTime + Right discovered <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + discovered `shouldNotContain` [("operator-suspended-1", "operator-suspended")] + + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (parentWorkflow childId) + Right Instance.WorkflowCancelRecorded <- + Store.runStoreIO storeHandle $ + Instance.cancelWorkflow childName childId + Store.runStoreIO storeHandle (runWorkflow parentName parentId (parentWorkflow childId)) + `shouldThrow` (== WorkflowChildCancelled childName childId) + + it "serializes cancellation against completion so exactly one marker wins" $ \storeHandle -> do + let name = WorkflowName "operator-terminal-race" + wid = WorkflowId "operator-terminal-race-1" + seededAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) + start <- newEmptyMVar + cancelDone <- newEmptyMVar + completeDone <- newEmptyMVar + _ <- forkIO $ do + takeMVar start + result <- Store.runStoreIO storeHandle $ Instance.cancelWorkflow name wid + putMVar cancelDone result + _ <- forkIO $ do + takeMVar start + completedAt <- getCurrentTime + result <- Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCompleted completedAt) + putMVar completeDone result + putMVar start () + putMVar start () + _ <- takeMVar cancelDone + _ <- takeMVar completeDone + Right hasCancelled <- Store.runStoreIO storeHandle $ stepExists name wid 0 cancelledStepName + Right hasCompleted <- Store.runStoreIO storeHandle $ stepExists name wid 0 completedStepName + (hasCancelled, hasCompleted) `shouldSatisfy` \case + (True, False) -> True + (False, True) -> True + _ -> False + + it "force-releases leases and makes the old owner stop at its next boundary" $ \storeHandle -> do + firstEffect <- newIORef (0 :: Int) + secondEffect <- newIORef (0 :: Int) + let name = WorkflowName "operator-force-release" + wid = WorkflowId "operator-force-release-1" + options owner = + defaultWorkflowRunOptions + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner, ttl = 60} + body = do + first <- + step (StepName "first") $ do + value <- liftIO (incrementAndRead firstEffect) + released <- Instance.forceReleaseInstanceLease name wid + liftIO (released `shouldBe` True) + pure value + second <- step (StepName "second") (liftIO (incrementAndRead secondEffect)) + pure (first, second) + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 name wid + claimedA `shouldBe` Instance.ClaimAcquired + lost <- + try + ( Store.runStoreIO storeHandle $ + runWorkflowWith (options "owner-a") name wid body + ) :: + IO + ( Either + WorkflowLeaseLost + (Either Store.StoreError (WorkflowOutcome (Int, Int))) + ) + lost `shouldBe` Left WorkflowLeaseLost + readIORef firstEffect `shouldReturn` 1 + readIORef secondEffect `shouldReturn` 0 + Right releasedAgain <- Store.runStoreIO storeHandle $ Instance.forceReleaseInstanceLease name wid + releasedAgain `shouldBe` False + + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 60 name wid + claimedB `shouldBe` Instance.ClaimAcquired + Right (Completed (1, 1)) <- + Store.runStoreIO storeHandle $ + runWorkflowWith (options "owner-b") name wid body + readIORef firstEffect `shouldReturn` 1 + readIORef secondEffect `shouldReturn` 1 + + it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-complete" + wid = WorkflowId "ic-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #workflowId `shouldBe` "ic-1" + row ^. #workflowName `shouldBe` "inst-complete" + row ^. #generation `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfCompleted + row ^. #completedAt `shouldSatisfy` isJust + + it "records suspended status for workflows that park before journaling" $ \storeHandle -> do + let name = WorkflowName "inst-suspended" + wid = WorkflowId "is-1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfSuspended + row ^. #generation `shouldBe` 0 + row ^. #completedAt `shouldBe` Nothing + + it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do + let childWid = WorkflowId "inst-child" + childName = WorkflowName "ship" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid) + Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + spawned ^. #status `shouldBe` Instance.WfRunning + Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid) + Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid + cancelledRow ^. #status `shouldBe` Instance.WfCancelled + cancelledRow ^. #completedAt `shouldSatisfy` isJust + + it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-rotate" + wid = WorkflowId "ir-1" + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (rollingTotal counter 1 2) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #generation `shouldBe` 1 + row ^. #status `shouldBe` Instance.WfRunning + + it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "inst-terminal" + wid = WorkflowId "it-1" + Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfCompleted + + it "discovers unfinished workflows from the instance table" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let completedName = WorkflowName "discover-completed" + cancelledName = WorkflowName "discover-cancelled" + crashedName = WorkflowName "discover-crashed" + rotatedName = WorkflowName "discover-rotated" + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow completedName (WorkflowId "done") (demoWorkflow counter) + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt) + Left (_ :: SimulatedCrash) <- + try $ + Store.runStoreIO storeHandle $ + runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter) + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2) + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished + `shouldBe` [ ("crashed", "discover-crashed"), + ("rotated", "discover-rotated") + ] + + describe "Keiro.Workflow discovery index" $ around (withFreshStore fixture) $ do + -- The discovery predicate must be stated as the positive active set + -- (status IN ('running','suspended')) rather than as the complement of the + -- terminal trio: Postgres proves partial-index applicability from the query + -- predicate alone and never consults the table's CHECK constraint, so the + -- complement form cannot use keiro_workflows_active_idx and seq-scans + -- keiro_workflows on every resume pass. With seq scans discouraged, a plan + -- that names the index is proof the planner can match it. + it "plans the discovery predicate through keiro_workflows_active_idx" $ \storeHandle -> do + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle $ + Store.runTransaction $ + for_ (discoveryFixtureRows now) $ \row -> + Tx.statement row insertWorkflowInstanceStmt + Right planLines <- Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Tx.sql "SET LOCAL enable_seqscan = off" + Tx.statement () explainDiscoveryStmt + Text.unpack (Text.intercalate "\n" planLines) + `shouldSatisfy` isInfixOf "keiro_workflows_active_idx" + + -- Exact discovery: 'running' always, 'suspended' only with a due wake hint. + -- A suspended instance with no hint is parked on a wake source that will + -- flip the row itself, so returning it would be pure waste. + it "returns exactly the runnable and wake-due instances" $ \storeHandle -> do + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle $ + Store.runTransaction $ + for_ (discoveryFixtureRows now) $ \row -> + Tx.statement row insertWorkflowInstanceStmt + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished + `shouldBe` [ ("a-running", "discovery-index"), + ("c-due-sleep", "discovery-index") + ] + + describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do + it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + let opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID" + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100 + Vector.length journal `shouldBe` 7 + Right snapshotVersionDuringFailure <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt + snapshotVersionDuringFailure `shouldBe` Nothing + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes" + recoveryCounter <- newIORef (0 :: Int) + recovery <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter) + recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapshotVersionAfterRecovery <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt + snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6) + + -- Validation (a): a snapshot row appears at the expected version and + -- decodes to the full accumulated step map. + it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "snap" + wid = WorkflowId "w1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6). + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 6) + -- and the row decodes to the six-entry accumulated map. + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1") + case mSeed of + Just (m, v) -> do + v `shouldBe` StreamVersion 6 + Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"] + Nothing -> expectationFailure "expected a workflow snapshot row" + + -- The OnTerminal completion-site wiring: only the final WorkflowCompleted + -- append (version 7) triggers the snapshot. + it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "term" + wid = WorkflowId "tm1" + result <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (countingSixSteps counter) + result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right snapVersion <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt + snapVersion `shouldBe` Just (StreamVersion 7) + + -- Validation (b): re-hydration reads only the tail after the snapshot + -- version, and the journaled steps short-circuit (the counter stays put). + it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "tail" + wid = WorkflowId "t1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterFirst <- readIORef counter + afterFirst `shouldBe` 6 + -- A full version-0 replay would read every journal event... + Right full <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100 + Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted + -- ...whereas the runtime seeds from the snapshot and reads only the tail. + Right (Just (seedMap, StreamVersion sv)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1") + Map.size seedMap `shouldBe` 6 + Right tailEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100 + Vector.length tailEvents `shouldSatisfy` (< Vector.length full) + Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7 + -- Re-hydration completes from the seed without re-running any step. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + afterSecond <- readIORef counter + afterSecond `shouldBe` 6 + + -- Validation (c): a Never run and an Every 2 run produce identical results + -- and identical journals, and the snapshot seed equals a full replay. + it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do + counterN <- newIORef (0 :: Int) + counterE <- newIORef (0 :: Int) + neverRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Never) + (WorkflowName "corr-never") + (WorkflowId "c1") + (countingSixSteps counterN) + everyRes <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2) + (WorkflowName "corr-every") + (WorkflowId "c1") + (countingSixSteps counterE) + neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + Right neverEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100 + Right everyEvents <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100 + let stepResults evs = + [ (k, v) + | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs + ] + stepResults neverEvents `shouldBe` stepResults everyEvents + -- The snapshot seed equals the map a full version-0 replay would fold. + Right (Just (seedMap, _)) <- + Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1") + seedMap `shouldBe` Map.fromList (stepResults everyEvents) + + -- Validation (d): an advisory snapshot whose discriminant no longer matches + -- is ignored and the workflow hydrates via full replay. + it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "dmiss" + wid = WorkflowId "d1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2 + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + + -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss. + it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do + (exporter, metricsRef) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + keiroMetrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "cjson" + wid = WorkflowId "d2" + opts = + defaultWorkflowRunOptions + & #snapshotPolicy + .~ Every 2 + & #metrics + ?~ keiroMetrics + _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt + Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2") + mSeed `shouldBe` Nothing + resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter) + resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6]) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef metricsRef + let scalars = flattenScalarPoints exported + lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2) + + describe "Keiro.Workflow snapshot wake-safety" $ around (withFreshStore fixture) $ do + it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-unsignalled" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + first <- run + first `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + rowAfterFirst ^. #status `shouldBe` Awk.Pending + rowAfterFirst ^. #payload `shouldBe` Nothing + second <- run + second `shouldBe` Right Suspended + Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + rowAfterSecond ^. #status `shouldBe` Awk.Pending + rowAfterSecond ^. #payload `shouldBe` Nothing + + it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-midrun-awakeable" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable + armed <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + armed `shouldBe` Right Suspended + first <- run + first `shouldBe` Right (Completed "payload") + second <- run + second `shouldBe` Right (Completed "payload") + + it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "snapshot-stale-awakeable" + wid = WorkflowId "wf1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + armed <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef) + armed `shouldBe` Right Suspended + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef) + first `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just (staleSeed, _)) <- + Store.runStoreIO storeHandle $ + loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) + staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid) + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo + second `shouldBe` Right (Completed "payload") + + it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do + let name = WorkflowName "snapshot-stale-child-parent" + wid = WorkflowId "wf1" + childWid = WorkflowId "child1" + opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1 + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid) + first `shouldBe` Right Suspended + Right (Just (staleSeed, _)) <- + Store.runStoreIO storeHandle $ + loadWorkflowSnapshot (workflowGenerationStreamName name wid 0) + staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid) + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid) + second `shouldBe` Right (Completed "packed+labelled") + + describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do + -- M2: crash mid-run, then a resume pass drives the workflow to Completed + -- without re-running the already-journaled step. + it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "crash-demo" + wid = WorkflowId "cd-1" + -- Simulate a crash after step 1's append has committed. + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () -- the SimulatedCrash unwound the run, as intended + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + readIORef counter >>= \c -> c `shouldBe` 1 + -- Resume with a registry mapping the name to the FULL definition. + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1, + advanced = 1, + resumed = 1, + completed = 1, + stillSuspended = 0, + unknownName = 0, + failed = 0, + transientErrors = 0, + leaseSkipped = 0, + paced = 0, + sleepDue = 0, + unregisteredNames = Set.empty + } + -- Step 1 short-circuited; steps 2 and 3 ran exactly once. + readIORef counter >>= \c -> c `shouldBe` 3 + -- The journal now holds s1, s2, s3, WorkflowCompleted. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True + _ -> False + -- A second pass discovers nothing — the workflow is finished. + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + + -- M3: a workflow suspended on an awaited step is driven to Completed once + -- that step is journaled (here simulated; an EP-39/EP-40 wake source would + -- journal the same StepRecorded end to end). + it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "await-demo" + wid = WorkflowId "ad-1" + suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter) + suspended `shouldBe` Right Suspended + -- Simulate the wake source resolving the await. + Right () <- Store.runStoreIO storeHandle $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now) + let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter)) + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` ResumeSummary + { discovered = 1, + advanced = 1, + resumed = 1, + completed = 1, + stillSuspended = 0, + unknownName = 0, + failed = 0, + transientErrors = 0, + leaseSkipped = 0, + paced = 0, + sleepDue = 0, + unregisteredNames = Set.empty + } + readIORef counter >>= \c -> c `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True + _ -> False + + -- M4: a discovered workflow whose name is absent from the registry is + -- skipped and counted, never silently dropped or fatal. + it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "orphan" + wid = WorkflowId "or-1" + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (crashAfterStep1 counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + -- Empty registry: the orphan is surfaced via unknownName, not completed. + Right summary <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty + summary + `shouldBe` ResumeSummary + { discovered = 1, + advanced = 0, + resumed = 0, + completed = 0, + stillSuspended = 0, + unknownName = 1, + failed = 0, + transientErrors = 0, + leaseSkipped = 0, + paced = 0, + sleepDue = 0, + unregisteredNames = Set.singleton "orphan" + } + -- The journal is unchanged: still one step, no completion. + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10 + Vector.length recorded `shouldBe` 1 + + it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "poison" + poisonId = WorkflowId "poison-1" + healthyName = WorkflowName "healthy" + healthyId = WorkflowId "healthy-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), + (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 2, + advanced = 2, + resumed = 2, + completed = 1, + failed = 1 + } + readIORef healthyCounter >>= \c -> c `shouldBe` 3 + Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId + poisonRow ^. #status `shouldBe` Instance.WfFailed + + -- Concurrency is opt-in and observable. Two workflows whose step actions + -- take ~300 ms run in overlapping windows under `maxConcurrentAdvances = 2` + -- and in disjoint windows under the default, so one slow step body no + -- longer delays every other workflow in the pass. + it "advances candidates concurrently only when the option allows it" $ \storeHandle -> do + let slowStep windows label = do + start <- liftIO getCurrentTime + liftIO (threadDelay 300_000) + end <- liftIO getCurrentTime + liftIO (modifyMVar windows (\ws -> pure ((label, start, end) : ws, ()))) + pure (1 :: Int) + runPass concurrency prefix = do + windows <- newMVar [] + let nameA = WorkflowName (prefix <> "-a") + nameB = WorkflowName (prefix <> "-b") + widA = WorkflowId (prefix <> "-1") + widB = WorkflowId (prefix <> "-2") + opts = + defaultWorkflowResumeOptions + & #maxConcurrentAdvances + .~ concurrency + & #logEvent + .~ const (pure ()) + registry = + Map.fromList + [ (nameA, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows ("a" :: Text)))), + (nameB, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows "b"))) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry nameA widA (StepRecorded "seed" (toJSON True) now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry nameB widB (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + completed summary `shouldBe` 2 + readMVar windows + concurrentWindows <- runPass 2 "overlap" + windowsOverlap concurrentWindows `shouldBe` True + serialWindows <- runPass 1 "serial" + windowsOverlap serialWindows `shouldBe` False + + -- Concurrency must not change what a pass reports or how it isolates a bad + -- candidate: the deltas are added at the end, so the summary cannot depend + -- on the order candidates finish in. Each phase runs against its own fresh + -- store, because an unknown-name candidate stays discoverable and would + -- otherwise carry into the next phase's counts. + it "reports a mixed pass the same way when advancing sequentially" $ \storeHandle -> do + summary <- runMixedResumePass storeHandle 1 + summary `shouldBe` expectedMixedResumeSummary + + it "reports a mixed pass the same way when advancing concurrently" $ \storeHandle -> do + summary <- runMixedResumePass storeHandle 3 + summary `shouldBe` expectedMixedResumeSummary + + it "records no crash attempt against a workflow that already went terminal" $ \storeHandle -> do + let name = WorkflowName "crash-race" + wid = WorkflowId "cr-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + -- A live instance paces normally. + Right live <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Instance.recordCrashTx "cr-1" "crash-race" "boom" + live `shouldBe` Just 1 + -- Once terminal, the UPDATE's status guard matches no row. That is the + -- answer, not an error: there is no live instance left to pace. + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (WorkflowCancelled cancelledAt) + Right afterTerminal <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Instance.recordCrashTx "cr-1" "crash-race" "boom" + afterTerminal `shouldBe` Nothing + + -- The race the arm above exists for. Workflow A goes terminal inside its own + -- run and then crashes, so the pass records its crash against a cancelled + -- instance. The zero-row result used to fail a single-row decoder, and + -- because the crash record sits outside the per-advance catches, the store + -- error escaped the whole pass: `resumeWorkflowsOnce` returned Left and + -- every remaining candidate was skipped until the next tick. + it "survives a crash recorded against a just-cancelled workflow" $ \storeHandle -> do + healthyCounter <- newIORef (0 :: Int) + events <- newIORef ([] :: [ResumeLogEvent]) + let raceName = WorkflowName "crash-race-pass" + raceId = WorkflowId "crp-1" + healthyName = WorkflowName "crash-race-healthy" + healthyId = WorkflowId "crh-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ (\event -> modifyIORef' events (event :)) + registry = + Map.fromList + [ ( raceName, + WorkflowDef + ( \_ -> do + cancelledAt <- liftIO getCurrentTime + appendJournalEntry raceName raceId (WorkflowCancelled cancelledAt) + liftIO (throwIO SimulatedCrash) *> pure (0 :: Int) + ) + ), + (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry raceName raceId (StepRecorded "seed" (toJSON True) now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry healthyName healthyId (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 2, + advanced = 1, + resumed = 2, + completed = 1, + transientErrors = 1 + } + -- The healthy workflow ran to completion regardless of which candidate + -- discovery returned first, and nothing was marked failed: a workflow that + -- is already cancelled must not also be condemned. + readIORef healthyCounter `shouldReturn` 3 + logged <- readIORef events + logged `shouldContain` [ResumeCrashRecordSkipped "crash-race-pass" "crp-1"] + Right (Just raceRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance raceName raceId + raceRow ^. #status `shouldBe` Instance.WfCancelled + raceRow ^. #attempts `shouldBe` 0 + + it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do + let name = WorkflowName "terminal-poison" + wid = WorkflowId "tp-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfFailed + row ^. #attempts `shouldBe` 1 + direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int))) + direct `shouldBe` Right Failed + Right recordedFailed <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed) + `shouldSatisfy` \case + Right events -> any (\case WorkflowFailed {} -> True; _ -> False) events + _ -> False + + it "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do + shouldCrash <- newIORef True + counter <- newIORef (0 :: Int) + let name = WorkflowName "resurrect-complete" + wid = WorkflowId "rc-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (recoverableWorkflow shouldCrash counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + readIORef counter `shouldReturn` 1 + + Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed failedPass `shouldBe` 1 + Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + failedRow ^. #status `shouldBe` Instance.WfFailed + + writeIORef shouldCrash False + resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + resurrected `shouldBe` Right Instance.WorkflowResurrected + Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + revivedRow ^. #status `shouldBe` Instance.WfRunning + revivedRow ^. #attempts `shouldBe` 0 + revivedRow ^. #lastError `shouldBe` Nothing + revivedRow ^. #nextAttemptAt `shouldBe` Nothing + + Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + completed completedPass `shouldBe` 1 + readIORef counter `shouldReturn` 2 + Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + completedRow ^. #status `shouldBe` Instance.WfCompleted + + it "can fail again in the same generation after resurrection" $ \storeHandle -> do + shouldCrash <- newIORef True + counter <- newIORef (0 :: Int) + let name = WorkflowName "resurrect-refail" + wid = WorkflowId "rr-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter)) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow name wid (recoverableWorkflow shouldCrash counter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + + Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed firstFailedPass `shouldBe` 1 + firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + firstRevival `shouldBe` Right Instance.WorkflowResurrected + Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed secondFailedPass `shouldBe` 1 + Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + refailedRow ^. #status `shouldBe` Instance.WfFailed + + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward + (workflowGenerationStreamName name wid 0) + (StreamVersion 0) + 10 + let failureIds = + [ event ^. #eventId + | event <- Vector.toList recorded, + Right decoded <- [decodeRecorded workflowJournalCodec event], + WorkflowFailed {} <- [decoded] + ] + case failureIds of + [firstFailureId, secondFailureId] -> + firstFailureId `shouldNotBe` secondFailureId + other -> + expectationFailure ("expected two failure events, got " <> show other) + + secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + secondRevival `shouldBe` Right Instance.WorkflowResurrected + + it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do + let runningName = WorkflowName "resurrect-running" + runningId = WorkflowId "running-1" + missingName = WorkflowName "resurrect-missing" + missingId = WorkflowId "missing-1" + childName = WorkflowName "resurrect-child" + childId = WorkflowId "child-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now) + runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId + runningOutcome `shouldBe` Right Instance.WorkflowNotFailed + missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId + missingOutcome `shouldBe` Right Instance.WorkflowNotFound + + Right childMarkedFailed <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Child.registerChildTx + "child-1" + "resurrect-child" + "parent-1" + "resurrect-parent" + "child:child-1:result" + Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure" + childMarkedFailed `shouldBe` True + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now) + + childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId + childOutcome `shouldBe` Right Instance.WorkflowResurrected + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child" + childRow ^. #status `shouldBe` Child.Running + childRow ^. #result `shouldBe` Nothing + childRow ^. #failureReason `shouldBe` Nothing + childRow ^. #completedAt `shouldBe` Nothing + + it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do + let name = WorkflowName "transient" + wid = WorkflowId "tr-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + _ <- throwError (Store.ConnectionLost "boom") + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + transientErrors summary `shouldBe` 1 + failed summary `shouldBe` 0 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #status `shouldBe` Instance.WfRunning + + it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do + done <- newEmptyMVar + healthyCounter <- newIORef (0 :: Int) + let poisonName = WorkflowName "fixed-loop-poison" + poisonId = WorkflowId "flp-1" + healthyName = WorkflowName "fixed-loop-healthy" + healthyId = WorkflowId "flh-1" + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 50_000 + & #maxAttempts + .~ 1 + & #logEvent + .~ const (pure ()) + healthyBody = threeStepThenSignal healthyCounter done + registry = + Map.fromList + [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))), + (healthyName, WorkflowDef (\_ -> healthyBody)) + ] + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now) + crashed <- + try + ( Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter) + ) :: + IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int)))) + case crashed of + Left _ -> pure () + Right other -> expectationFailure ("expected a simulated crash, got " <> show other) + worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry))) + completed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + completed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do + let name = WorkflowName "lease-claim" + wid = WorkflowId "lc-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` Instance.ClaimAcquired + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` Instance.ClaimLeaseHeld + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid + Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedBAfterRelease `shouldBe` Instance.ClaimAcquired + + it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do + let name = WorkflowName "lease-expire" + wid = WorkflowId "le-1" + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid + claimedA `shouldBe` Instance.ClaimAcquired + Right attempt <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Instance.recordCrashTx "le-1" "lease-expire" "boom" + attempt `shouldBe` Just 1 + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid + Right pacedClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + pacedClaim `shouldBe` Instance.ClaimPaced + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'" + Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid + claimedB `shouldBe` Instance.ClaimAcquired + Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #attempts `shouldBe` 0 + row ^. #lastError `shouldBe` Nothing + row ^. #nextAttemptAt `shouldBe` Nothing + row ^. #leasedBy `shouldBe` Nothing + + it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do + ran <- newIORef False + let name = WorkflowName "lease-skip" + wid = WorkflowId "ls-1" + registry = + Map.singleton name $ + WorkflowDef + ( \_ -> do + liftIO (writeIORef ran True) + pure (0 :: Int) + ) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now) + Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid + foreignClaim `shouldBe` Instance.ClaimAcquired + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary + `shouldBe` emptyResumeSummary + { discovered = 1, + leaseSkipped = 1 + } + readIORef ran `shouldReturn` False + + -- M4: resume on an already-completed workflow is a genuine no-op. + it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "done-demo" + wid = WorkflowId "dd-1" + done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter) + done `shouldBe` Right (Completed (1, 2, 3)) + readIORef counter >>= \c -> c `shouldBe` 3 + let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter)) + Right summary1 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary1 `shouldBe` emptyResumeSummary + Right summary2 <- + Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry + summary2 `shouldBe` emptyResumeSummary + readIORef counter >>= \c -> c `shouldBe` 3 + + describe "Keiro.Workflow lease renewal" $ around (withFreshStore fixture) $ do + it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do + attemptedClaim <- newIORef Nothing + let name = WorkflowName "lease-heartbeat" + wid = WorkflowId "heartbeat-1" + runOpts = + defaultWorkflowRunOptions + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} + body = + step (StepName "slow-boundary") $ do + liftIO (threadDelay 300_000) + claimed <- + Instance.claimInstance + "owner-b" + 60 + name + wid + liftIO (writeIORef attemptedClaim (Just claimed)) + pure (claimed == Instance.ClaimAcquired) + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid + claimedA `shouldBe` Instance.ClaimAcquired + outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body + outcome `shouldBe` Right (Completed False) + readIORef attemptedClaim `shouldReturn` Just Instance.ClaimLeaseHeld + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #leasedBy `shouldBe` Just "owner-a" + + it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do + let directName = WorkflowName "lease-lost-direct" + directId = WorkflowId "lost-direct-1" + directOpts = + defaultWorkflowRunOptions + & #leaseHeartbeat + .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60} + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now) + Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId + claimedA `shouldBe` Instance.ClaimAcquired + leaseUntil <- addUTCTime 60 <$> getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement + ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil) + forceWorkflowLeaseStmt + firstDirectEffect <- newIORef (0 :: Int) + secondDirectEffect <- newIORef (0 :: Int) + direct <- + try + ( Store.runStoreIO storeHandle $ + runWorkflowWith directOpts directName directId $ do + _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect)) + step (StepName "second") (liftIO (incrementAndRead secondDirectEffect)) + ) :: + IO + ( Either + WorkflowLeaseLost + (Either Store.StoreError (WorkflowOutcome Int)) + ) + direct `shouldBe` Left WorkflowLeaseLost + readIORef firstDirectEffect `shouldReturn` 0 + readIORef secondDirectEffect `shouldReturn` 0 + directFinishedAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry directName directId (WorkflowCompleted directFinishedAt) + + firstWorkerEffect <- newIORef (0 :: Int) + secondWorkerEffect <- newIORef (0 :: Int) + let workerName = WorkflowName "lease-lost-worker" + workerId = WorkflowId "lost-worker-1" + workerOpts = + defaultWorkflowResumeOptions + & #logEvent + .~ const (pure ()) + registry = + Map.singleton workerName $ + WorkflowDef $ \_ -> do + _ <- + step (StepName "first") $ do + value <- liftIO (incrementAndRead firstWorkerEffect) + expires <- liftIO (addUTCTime 60 <$> getCurrentTime) + Store.runTransaction $ + Tx.statement + ("lost-worker-1", "lease-lost-worker", "owner-b", expires) + forceWorkflowLeaseStmt + pure value + step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect)) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry + summary + `shouldBe` emptyResumeSummary + { discovered = 1, + leaseSkipped = 1 + } + readIORef firstWorkerEffect `shouldReturn` 1 + readIORef secondWorkerEffect `shouldReturn` 0 + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId + row ^. #attempts `shouldBe` 0 + row ^. #leasedBy `shouldBe` Just "owner-b" + + describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do + -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that + -- rotates every 50 steps keeps each physical generation journal bounded by + -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that + -- opened the generation + the one terminal marker), yet returns the correct + -- final total. A single non-rotating run would put all 300 steps on one + -- journal and the per-generation `<= K` bound would fail. + it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller" + wid = WorkflowId "r-1" + rotateEvery = 50 :: Int + total = 300 :: Int + k = rotateEvery + 2 + body = rollingTotal counter rotateEvery total + -- Re-invoke runWorkflow until it Completes; each call resolves and + -- advances the current generation, exactly as the resume worker does. + drive :: Int -> IO Int + drive budget + | budget <= 0 = + expectationFailure "workflow did not complete within the rotation budget" >> pure (-1) + | otherwise = do + outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + case outcome of + Right ContinuedAsNew -> drive (budget - 1) + Right (Completed t) -> pure t + other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1) + -- The first invocation rotates (generation 0 did rotateEvery steps). + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body) + firstOutcome `shouldBe` Right ContinuedAsNew + -- Drive the remaining generations to completion (bounded passes). + finalTotal <- drive (total `div` rotateEvery + 3) + -- Check 2: correct result, and each side effect ran exactly once. + finalTotal `shouldBe` total + readIORef counter >>= (`shouldBe` total) + -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5). + Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid) + gen `shouldBe` (total `div` rotateEvery - 1) + -- Check 1: every generation's physical journal is bounded by K, and the + -- total is split ACROSS generations (bounded per generation, not in + -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1 + -- marker = K events, so the sum is total + 2 per generation. + lengths <- + traverse + ( \g -> do + let streamName = workflowGenerationStreamName name wid g + Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000) + pure (Vector.length evs) + ) + [0 .. gen] + for_ lengths (`shouldSatisfy` (<= k)) + sum lengths `shouldBe` (total + 2 * (gen + 1)) + -- The first generation ends with a rotation marker; the last with a + -- completion marker. + Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs) + `shouldSatisfy` any + ( \case + Right (WorkflowContinuedAsNew 1 _) -> True + _ -> False + ) + Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000) + (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs) + `shouldSatisfy` any + ( \case + Right (WorkflowCompleted _) -> True + _ -> False + ) + + -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a + -- rotation the rotated (newer) generation is unfinished and discoverable — + -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and + -- the resume worker drives the rotated generation forward to completion. + it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "roller2" + wid = WorkflowId "r-2" + rotateEvery = 50 :: Int + total = 150 :: Int + registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total)) + resumeUntilDone :: Int -> IO () + resumeUntilDone budget + | budget <= 0 = expectationFailure "resume did not complete the rotated workflow" + | otherwise = do + Right summary <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + if completed summary == 1 then pure () else resumeUntilDone (budget - 1) + -- First run rotates onto generation 1. + firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total)) + firstOutcome `shouldBe` Right ContinuedAsNew + -- The rotated current generation (1) is unfinished and discoverable. + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("r-2", "roller2")] + -- The resume worker drives the rotated generation(s) to completion. + resumeUntilDone (total `div` rotateEvery + 3) + readIORef counter >>= (`shouldBe` total) + -- Finished: discovery now reports nothing for it. + finalNow <- getCurrentTime + Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow) + finalUnfinished `shouldBe` [] + + describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do + it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patchwf" + inflight = WorkflowId "inflight-1" + fresh = WorkflowId "fresh-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + + -- 1. Run the in-flight instance to a suspension under the PRE-patch code. + pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter) + pre `shouldBe` Right Suspended + + -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It + -- already journaled reserve-inventory, so it is in flight -> False. + r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r1 `shouldBe` Right (Completed "old-branch") + + -- 3. Replay the in-flight instance again: same OLD branch, every time. + r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter) + r2 `shouldBe` Right (Completed "old-branch") + + -- 4. A fresh instance under the POST-patch code takes the NEW branch. + f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f1 `shouldBe` Right (Completed "new-branch") + -- and stays on the new branch on replay. + f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter) + f2 `shouldBe` Right (Completed "new-branch") + + -- 5. The patch decision is journaled exactly once per instance, with the + -- expected Bool, on the patch: key. + Right inflightJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20 + let inflightDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal), + StepRecorded k v _ <- [ev], + k == patchStepName fraudPatchId + ] + inflightDecisions `shouldBe` [toJSON False] + + Right freshJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20 + let freshDecisions = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), + StepRecorded k v _ <- [ev], + k == patchStepName fraudPatchId + ] + freshDecisions `shouldBe` [toJSON True] + let freshPatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal), + StepRecorded k v _ <- [ev], + k == patchSetStepName + ] + freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "patch-after-suspend" + wid = WorkflowId "pas-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter) + resumed `shouldBe` Right (Completed "new-branch") + + it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do + let name = WorkflowName "patch-wake-only" + wid = WorkflowId "pwo-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now) + resumed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow + resumed `shouldBe` Right (Completed "old-branch") + + it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do + let name = WorkflowName "patch-rotating" + wid = WorkflowId "pr-1" + patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId + first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + first `shouldBe` Right ContinuedAsNew + second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow + second `shouldBe` Right (Completed "new-branch") + Right gen1Journal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20 + let gen1PatchSets = + [ v + | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal), + StepRecorded k v _ <- [ev], + k == patchSetStepName + ] + gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + + describe "Keiro.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do + it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do + let name = WorkflowName "patch-rotation-race" + wid = WorkflowId "prr-1" + patchOptions = + defaultWorkflowRunOptions + & #activePatches + .~ Set.singleton fraudPatchId + generationOneStream = workflowGenerationStreamName name wid 1 + + first <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + first `shouldBe` Right ContinuedAsNew + Right patchSetRecorded <- + Store.runStoreIO storeHandle $ + stepExists name wid 1 patchSetStepName + patchSetRecorded `shouldBe` True + + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry + name + wid + ( StepRecorded + "awk:11111111-1111-1111-1111-111111111111" + (toJSON True) + now + ) + + second <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + second `shouldBe` Right (Completed "new-branch") + replayed <- + Store.runStoreIO storeHandle $ + runWorkflowWith patchOptions name wid rotatingPatchWorkflow + replayed `shouldBe` Right (Completed "new-branch") + + Right generationOneJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward generationOneStream (StreamVersion 0) 20 + let decoded = + map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal) + patchSets = + [ value + | Right (StepRecorded key value _) <- decoded, + key == patchSetStepName + ] + decisions = + [ value + | Right (StepRecorded key value _) <- decoded, + key == patchStepName fraudPatchId + ] + patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]] + decisions `shouldBe` [toJSON True] + + describe "Keiro.Wake" $ around (withFreshStore fixture) $ do + -- EP-50: the wake primitive over kiroku's existing per-store notifier. + it "returns WokenByTimeout when idle (no append)" $ \store -> do + wake <- wakeSignalFromStore store + reason <- waitForWake wake 200000 -- 200 ms + reason `shouldBe` WokenByTimeout + + it "returns WokenByNotify promptly after a real append" $ \store -> do + wake <- wakeSignalFromStore store + -- A real append bumps the streams row and fires kiroku's NOTIFY on + -- kiroku.events; the store's notifier ticks the broadcast channel. + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now) + reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds + reason `shouldBe` WokenByNotify + + it "neverWake always returns WokenByTimeout" $ \_store -> do + reason <- waitForWake neverWake 100000 + reason `shouldBe` WokenByTimeout + + describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do + -- The user-visible win: a gated workflow resumes within sub-second of the + -- gate append, under a deliberately large (10 s) fallback — so a pass that + -- resumes it sub-second can only have been woken by the NOTIFY, not the poll. + it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "pushwf" + wid = WorkflowId "p-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + -- Let the worker start, duplicate the tick channel, and park in its wait + -- before we append, so the gate's NOTIFY cannot be missed. + threadDelay 250000 + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + t1 <- getCurrentTime + killThread worker + resumed `shouldBe` Just () + let latency = realToFrac (diffUTCTime t1 now) :: Double + latency `shouldSatisfy` (< 1.0) + + it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do + done <- newEmptyMVar + logs <- newIORef [] + let name = WorkflowName "push-recover" + wid = WorkflowId "pr-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + opts = + defaultWorkflowResumeOptions + & #pollInterval + .~ 100_000 + & #logEvent + .~ \event -> modifyIORef' logs (<> [event]) + waitForPassFailure = timeout 5_000_000 $ do + let go = do + seen <- readIORef logs + if any isPassFailure seen + then pure () + else threadDelay 20_000 >> go + go + isPassFailure = \case + ResumePassFailed {} -> True + _ -> False + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + -- Break the table discovery itself reads, so every pass fails outright. + -- (Hiding keiro_workflow_steps no longer suffices: under exact discovery + -- the parked workflow is not returned, so a pass never reaches it.) + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflows RENAME TO keiro_workflows_hidden" + worker <- forkIO (runWorkflowResumeWorkerPush store opts registry) + logged <- waitForPassFailure + logged `shouldBe` Just () + Right () <- + Store.runStoreIO store $ + Store.runTransaction $ + Tx.sql "ALTER TABLE keiro.keiro_workflows_hidden RENAME TO keiro_workflows" + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5_000_000 (takeMVar done) + status <- threadStatus worker + killThread worker + resumed `shouldBe` Just () + status `shouldSatisfy` \case + ThreadFinished -> False + ThreadDied -> False + _ -> True + + describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do + -- Push is strictly an optimization: with the worker on 'neverWake' (every + -- NOTIFY dropped) and a small fallback, the gated workflow still drains on + -- the durable poll. + it "still drains on the fallback timeout when no notification is delivered" $ \store -> do + done <- newEmptyMVar + let name = WorkflowName "fallbackwf" + wid = WorkflowId "f-1" + registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done)) + onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)) + first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done)) + first `shouldBe` Right Suspended + worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications + now <- getCurrentTime + Right () <- + Store.runStoreIO store $ + appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now) + resumed <- timeout 5000000 (takeMVar done) + killThread worker + resumed `shouldBe` Just () + + describe "Shard lease" $ around (withFreshStore fixture) $ do + -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit + -- `now` timestamps standing in for the passage of time (no workers yet). The + -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and + -- failover are both observable purely from the lease table. + let subName = SubscriptionName "orders-shard" + wA = WorkerId sampleUuid + wB = WorkerId sampleUuid2 + ttl = 30 :: NominalDiffTime + t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + tExpired = addUTCTime 60 t0 -- past A's 30 s lease + shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4 + it "validates sharded worker options before startup" $ \_store -> do + shouldBeRight_ (mkShardedWorkerOptions shardOpts) + mkShardedWorkerOptions (shardOpts & #shardCount .~ 0) + `shouldBeLeft` InvalidShardCount 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0) + `shouldBeLeft` InvalidShardLeaseTtl 0 + mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0) + `shouldBeLeft` InvalidShardRenewInterval 0 + mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10) + `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10 + mkShardedWorkerOptions (shardOpts & #batchSize .~ 0) + `shouldBeLeft` InvalidShardBatchSize 0 + mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0) + `shouldBeLeft` InvalidShardBufferSize 0 + mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1)) + `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1)) + mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0) + `shouldBeLeft` InvalidShardRetryMaxAttempts 0 + + it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + ensureShardRows subName 4 + Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName) + map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3] + all (\(_, o, _) -> isNothing o) rows `shouldBe` True + + it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do + Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + claimedA `shouldBe` [0, 1, 2, 3] + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [] + + it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + claimShardsTx subName wA 4 t0 ttl + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl) + claimedB `shouldBe` [0, 1, 2, 3] + -- A lost every bucket to B, so its renew returns the empty set: this is how + -- a worker learns it no longer owns a bucket and stops reading it. + Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl) + heldA `shouldBe` [] + + it "renewLease returns only still-held buckets" $ \store -> do + Right held <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + renewLeaseTx subName wA t0 ttl + held `shouldBe` [0, 1, 2, 3] + + it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do + Right _ <- Store.runStoreIO store $ Store.runTransaction $ do + ensureShardRows subName 4 + _ <- claimShardsTx subName wA 4 t0 ttl + releaseShardsTx subName wA [0, 1] + -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable. + Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl) + claimedB `shouldBe` [0, 1] + + it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do + fairShareTarget 6 3 `shouldBe` 2 + fairShareTarget 6 4 `shouldBe` 2 + fairShareTarget 7 3 `shouldBe` 3 + fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything + it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do + let previous = Set.fromList [0, 2] + acquireOutcome previous (Left "database unavailable") + `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable")) + acquireOutcome previous (Right (Set.fromList [1, 3])) + `shouldBe` (Set.fromList [1, 3], Nothing) + + it "ensureShards rejects a shardCount mismatch" $ \store -> do + let lease4 = + ShardLease + { subscriptionName = subName, + workerId = wA, + shardCount = 4, + leaseTtl = ttl + } + lease6 = + ShardLease + { subscriptionName = subName, + workerId = wA, + shardCount = 6, + leaseTtl = ttl + } + Right () <- Store.runStoreIO store (ensureShards lease4) + Store.runStoreIO store (ensureShards lease6) + `shouldThrow` \case + ShardCountMismatch name configured found -> + name == "orders-shard" && configured == 6 && found == [4] + + describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do + -- EP-51 M3: one process owning all N buckets drains a seeded category exactly + -- once. The sink is idempotent on event_id, so "count == total" proves every + -- event was delivered with none missing and none surviving as a duplicate row. + it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 8 5 -- 40 events across 8 streams + let opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3, + renewInterval = 0.3 + } + w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + count <- shardSinkCount store + count `shouldBe` total + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + + describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do + -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively + -- partition a category; we let ownership converge on the *empty* category + -- first (so the churn of cold-start rebalancing touches no events), then seed + -- and drain under stable membership — so each stream is owned by exactly one + -- worker throughout the drain. Then we kill a worker and prove its buckets are + -- re-homed and the new events drain (failover via lease expiry). + let sub = SubscriptionName "orders-failover" + mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6) {leaseTtl = 3, renewInterval = 0.3} + it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1)) + w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2)) + w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3)) + -- Wait for cooperative balance on the empty category: all 6 buckets owned, + -- spread across >= 2 workers, none holding more than its fair share. + balanced <- waitShardsBalanced store sub 6 2 15_000_000 + balanced `shouldBe` True + -- Now seed and drain under stable membership. + total1 <- seedOrders store 12 5 -- 60 events + ok1 <- waitUntilSinkCount store total1 25_000_000 + ok1 `shouldBe` True + -- Disjoint: no stream key was processed by two workers (stable membership, + -- so no re-homing split any stream). + maxW <- maxWorkersPerStream store + maxW `shouldBe` 1 + -- The work genuinely spread (not a monopoly): at least two workers participated. + spread <- distinctWorkers store + spread `shouldSatisfy` (>= 2) + -- Counts sum to total with no duplicate event id (PK on event_id + count). + c1 <- shardSinkCount store + c1 `shouldBe` total1 + -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire). + killThread w1 + -- Seed more across all streams; some hash to worker 1's now-orphaned buckets. + total2 <- seedOrders store 12 5 -- another 60 + -- Failover: a surviving worker re-claims the expired buckets and drains the + -- new events. If re-homing did not happen, events on worker 1's buckets would + -- never drain and this would time out. + ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000 + killThread w2 + killThread w3 + ok2 `shouldBe` True + c2 <- shardSinkCount store + c2 `shouldBe` (total1 + total2) + + it "a killed worker relinquishes its leases immediately" $ \store -> do + let subImmediate = SubscriptionName "orders-immediate-release" + longTtlOpts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 30, + renewInterval = 0.2 + } + w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1)) + owned <- waitShardsBalanced store subImmediate 4 1 10_000_000 + owned `shouldBe` True + killThread w + released <- waitShardsUnowned store subImmediate 4 3_000_000 + released `shouldBe` True + + it "a handler exception is retried in place and drains" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + thrown <- newIORef False + errors <- newIORef [] + let subRestart = SubscriptionName "orders-reader-restart" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2) + { leaseTtl = 3, + renewInterval = 0.2, + handlerRetryDelay = KirokuSub.RetryDelay 0.05, + onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + firstTime <- + atomicModifyIORef' + thrown + ( \seen -> + if seen + then (seen, False) + else (True, True) + ) + when firstTime (throwIO (userError "reader boom")) + sinkHandler store 1 ev + w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler) + balanced <- waitShardsBalanced store subRestart 2 1 10_000_000 + balanced `shouldBe` True + total <- seedOrders store 4 2 + drained <- waitUntilSinkCount store total 20_000_000 + killThread w + drained `shouldBe` True + seenErrors <- readIORef errors + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do + it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + enteredTail <- newEmptyMVar + holdTail <- newEmptyMVar + let sub = SubscriptionName "orders-ack-tail" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3, + renewInterval = 0.3 + } + blockingHandler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + when (orderNumber == Right (4 :: Int)) $ do + putMVar enteredTail () + takeMVar holdTail + sinkHandler store 1 ev + first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler) + entered <- timeout 10_000_000 (takeMVar enteredTail) + entered `shouldBe` Just () + -- The old pull bridge replies Continue before invoking the handler; + -- leave enough time for its batch-tail checkpoint to commit while the + -- handler remains blocked. The ack-coupled bridge introduced by EP-96 + -- remains blocked on the unfilled reply instead. + threadDelay 200_000 + killThread first + second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2)) + drained <- waitUntilSinkCount store total 20_000_000 + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 24 5 + let sub = SubscriptionName "orders-ack-rebalance" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4) + { leaseTtl = 3, + renewInterval = 0.3, + batchSize = 1 + } + slowHandler tag ev = do + threadDelay 100_000 + sinkHandler store tag ev + first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1)) + -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner + -- while A owns three leaves one claimable bucket for B, making B visible; + -- A's next pass then sheds its excess third bucket while its handler is + -- deliberately slow and in flight. + ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000 + ownsThree `shouldBe` True + second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2)) + drained <- waitUntilSinkCount store total 30_000_000 + killThread first + killThread second + drained `shouldBe` True + shardSinkCount store `shouldReturn` total + + it "allows zombie overlap duplicates without losing an event" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 5 + entered <- newEmptyMVar + release <- newEmptyMVar + deliveries <- newIORef ([] :: [EventId]) + successor <- newIORef Nothing + readersA <- newIORef Map.empty + let sub = SubscriptionName "orders-ack-zombie" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 2, + renewInterval = 0.2 + } + leaseA = + ShardLease + { subscriptionName = sub, + workerId = WorkerId sampleUuid, + shardCount = 1, + leaseTtl = 2 + } + handlerA delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + putMVar entered () + takeMVar release + sinkHandler store 1 ev + pure ShardAckOk + handlerB delivery = do + let ev = delivery ^. #event + modifyIORef' deliveries ((ev ^. #eventId) :) + sinkHandler store 2 ev + pure ShardAckOk + cleanup = do + void (tryPutMVar release ()) + mSuccessor <- readIORef successor + for_ mSuccessor killThread + now <- getCurrentTime + let cleanupWorker = WorkerId sampleUuid2 + _ <- Store.runStoreIO store $ Store.runTransaction $ do + releaseShardsTx sub (WorkerId sampleUuid) [0] + claimShardsTx sub cleanupWorker 1 now 30 + void (reconcileShardsOnce store leaseA opts readersA handlerA) + ( do + Right () <- Store.runStoreIO store (ensureShards leaseA) + void (reconcileShardsOnce store leaseA opts readersA handlerA) + timeout 10_000_000 (takeMVar entered) `shouldReturn` Just () + -- A no longer renews, but its reader remains alive and blocked + -- with one unacknowledged event. B can claim after expiry and + -- must therefore receive that event again from the checkpoint. + threadDelay 2_500_000 + workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB) + writeIORef successor (Just workerB) + drained <- waitUntilSinkCount store total 20_000_000 + drained `shouldBe` True + raw <- readIORef deliveries + length raw `shouldSatisfy` (> total) + shardSinkCount store `shouldReturn` total + ) + `finally` cleanup + + it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do + Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql) + total <- seedOrders store 1 4 + poisonDeliveries <- newIORef (0 :: Int) + errors <- newIORef [] + let sub = SubscriptionName "orders-ack-poison" + opts = + (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1) + { leaseTtl = 3, + renewInterval = 0.2, + handlerRetryDelay = KirokuSub.RetryDelay 0.05, + retryPolicy = KirokuSub.RetryPolicy 3, + onShardError = Just (\err -> modifyIORef' errors (err :)) + } + handler ev = do + let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload) + if orderNumber == Right (1 :: Int) + then do + modifyIORef' poisonDeliveries (+ 1) + throwIO (userError "poison order") + else sinkHandler store 1 ev + worker <- forkIO (runShardedSubscriptionGroup store sub opts handler) + drained <- waitUntilSinkCount store (total - 1) 20_000_000 + details <- shardDeadLetterDetails store "orders-ack-poison" + attempts <- readIORef poisonDeliveries + seenErrors <- readIORef errors + killThread worker + drained `shouldBe` True + attempts `shouldBe` 3 + details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3) + seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True) + + describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do + -- The headline operability signal: executed (real work) vs replayed + -- (recorded history), recorded by the runtime through an SDK meter and read + -- back from the in-memory exporter — plus the active gauge and the + -- journal-length histogram. + it "records workflow instruments through an SDK meter" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs" + wid = WorkflowId "obs-1" + opts = defaultWorkflowRunOptions & #metrics .~ Just metrics + -- First run: both steps miss → two executions. + first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + first `shouldBe` Right (Completed (1, 2)) + -- Second run, same id: both steps hit → two replays. + second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter) + second `shouldBe` Right (Completed (1, 2)) + -- The side effects ran exactly twice across both runs (the replay run + -- short-circuited every step). + readIORef counter >>= \c -> c `shouldBe` 2 + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + hists = flattenHistogramPoints exported + lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2) + lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2) + -- One journal-length observation per completed run (two completions). + [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2] + -- Both runs finished, so the live-run count returned to zero. + lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0) + + -- The resume worker increments keiro.workflow.resumed per re-invocation and + -- samples keiro.workflow.awakeables.pending each pass. + it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + meter <- getMeter provider Telemetry.keiroInstrumentationLibrary + metrics <- Telemetry.newKeiroMetrics meter + counter <- newIORef (0 :: Int) + let name = WorkflowName "obs-resume" + wid = WorkflowId "obs-r-1" + -- Park a workflow on the first of two gates, then journal that gate's + -- result. The append flips the instance row to running, which is what + -- makes exact discovery return it; the re-invocation then parks on the + -- second gate and stays Suspended, which still counts as a re-invocation. + suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (twoGateWorkflow counter) + suspended `shouldBe` Right Suspended + gateAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "awk:first" (toJSON ()) gateAt) + -- Register one pending awakeable (independent of the suspended workflow's + -- own await) so the pending gauge has something to count. + let aid = awakeableIdToUuid (generation0AwakeableId (WorkflowName "ext") (WorkflowId "1") "cb") + Right () <- + Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1" + -- One resume pass with metrics threaded through the run options. + let registry = Map.singleton name (WorkflowDef (\_wid -> twoGateWorkflow counter)) + resumeOpts = + defaultWorkflowResumeOptions + & #runOptions + .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry + (discovered summary, resumed summary, stillSuspended summary) `shouldBe` (1, 1, 1) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + let scalars = flattenScalarPoints exported + lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1) + lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1) + + -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics = + -- Nothing, so a run on a dedicated provider exports no points at all. + it "records nothing through a Nothing handle" $ \storeHandle -> do + (exporter, ref) <- inMemoryMetricExporter + (provider, _env) <- + createMeterProvider + emptyMaterializedResources + defaultSdkMeterProviderOptions {metricExporter = Just exporter} + counter <- newIORef (0 :: Int) + result <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter) + result `shouldBe` Right (Completed (1, 2)) + _ <- forceFlushMeterProvider provider Nothing + exported <- readIORef ref + flattenScalarPoints exported `shouldBe` [] + flattenHistogramPoints exported `shouldBe` [] + + describe "Keiro.Workflow.Snapshot codec" $ do + -- Pure (no-DB) round-trip of the workflow state codec. + it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do + let m = + Map.fromList + [ ("first", toJSON (1 :: Int)), + ("second", toJSON ["a", "b" :: Text]), + ("sleep:42", Aeson.Null) + ] + (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m + (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1" + (workflowStateCodec ^. #stateShapeHash) `shouldBe` "keiro.workflow.stepmap.v1" + (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1 + + describe "Keiro.Workflow.Types journal codec" $ do + -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the + -- additive WorkflowContinuedAsNew constructor encodes and decodes + -- self-describingly within schemaVersion 1. + it "round-trips a WorkflowContinuedAsNew rotation marker" $ do + let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600) + marker = WorkflowContinuedAsNew 3 t + (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker) + `shouldBe` Right marker + (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1 + EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True + + it "validates workflow identity smart constructors" $ do + mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment") + mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty + mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment") + mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment") + mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1") + mkWorkflowId "550e8400-e29b-41d4-a716-446655440000" + `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000") + mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty + mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42") + mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42") + + describe "Keiro deterministic id derivation" $ do + -- Deterministic ids are replay identity: the same seed must yield the same + -- id on every deploy, forever (ADR 24). Every literal below was captured + -- from the *previous* derivation — which hashed each character's codepoint + -- modulo 256 — before it was replaced by UTF-8 seed bytes. For ASCII seeds + -- the two encodings agree byte for byte, so a failure here means a + -- deployed id moved. Regenerate a literal only alongside a versioned + -- derivation and a migration story, never to make the suite green. + let name = WorkflowName "orderFulfillment" + wid = WorkflowId "wf-1" + sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301") + + it "freezes the ASCII journal-event ids, reserved step names included" $ do + deterministicJournalId name wid 0 "charge-card" + `shouldBe` EventId (uuidLiteral "1618b21a-5321-536f-998b-99f88f078148") + deterministicJournalId name wid 1 "charge-card" + `shouldBe` EventId (uuidLiteral "ddbf5d19-df0d-50f7-9aa2-9c8214bfde00") + deterministicJournalId name wid 0 completedStepName + `shouldBe` EventId (uuidLiteral "5ac985e8-4168-5705-91bc-5523833d3f60") + deterministicJournalId name wid 0 cancelledStepName + `shouldBe` EventId (uuidLiteral "52493d94-d35a-5a7e-8ce9-40e1111c45f9") + deterministicJournalId name wid 0 failedStepName + `shouldBe` EventId (uuidLiteral "b7ed900d-0fac-54dd-87b1-a01f6782a298") + deterministicJournalId name wid 0 continuedAsNewStepName + `shouldBe` EventId (uuidLiteral "338f8962-ef47-5992-a4e0-c314358a2f05") + deterministicJournalId name wid 0 continueSeedStepName + `shouldBe` EventId (uuidLiteral "268c2031-b026-564a-be24-85cab59c3ce7") + deterministicJournalId name wid 0 patchSetStepName + `shouldBe` EventId (uuidLiteral "c188a7f9-617d-59e5-8e09-4498d7daf477") + deterministicJournalId name wid 0 (patchStepName (PatchId "new-tax")) + `shouldBe` EventId (uuidLiteral "64de4580-0a2d-522b-b397-e25c6ee3eacc") + deterministicJournalId name wid 0 (sleepStepName (StepName "cool")) + `shouldBe` EventId (uuidLiteral "e3a009bd-f287-5331-9f72-8e273f0040cf") + + it "freezes the ASCII sleep, awakeable, and process-manager ids" $ do + sleepTimerId name wid 0 "sleep:cool" + `shouldBe` TimerId (uuidLiteral "cfebe58e-b34c-5031-af98-18e71e6f4cfa") + sleepTimerId name wid 1 "sleep:cool" + `shouldBe` TimerId (uuidLiteral "e9696450-3993-59da-902e-4e5ebcfd1ab0") + sleepTimerId name wid 2 "sleep:cool" + `shouldBe` TimerId (uuidLiteral "6affc998-5cf2-51d0-9bbb-22e792581433") + generation0AwakeableId name wid "approval" + `shouldBe` AwakeableId (uuidLiteral "f677231c-8a27-51b6-9a5e-69015262b26f") + deterministicCommandId "counter-pm" "order-1" sourceEventId 0 + `shouldBe` EventId (uuidLiteral "ff20892c-6665-5e92-8c99-d1569d2ce629") + deterministicCommandId "counter-pm" "order-1" sourceEventId (-1) + `shouldBe` EventId (uuidLiteral "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef") + + it "freezes target-keyed process-reaction ids and their byte preimage" $ do + let asciiId = + Reaction.deterministicReactionCommandId + "billing" + "order:1" + sourceEventId + (StreamName "account:42") + 0 + explicitPreimage = + "5:keiro16:process-reaction7:billing7:order:136:3f2504e0-4f89-51d3-9a0c-0305e82c330110:account:421:0" + independentlyHashed = + EventId + ( UUID.V5.generateNamed + UUID.V5.namespaceURL + (ByteString.unpack (TE.encodeUtf8 explicitPreimage)) + ) + asciiId `shouldBe` EventId (uuidLiteral "5a89007a-a634-58bf-8002-5ea7843155f2") + asciiId `shouldBe` independentlyHashed + Reaction.deterministicReactionCommandId + "\x4E2D\x6587" + "corr:\x0101" + sourceEventId + (StreamName "target:\x1F600") + 0 + `shouldBe` EventId (uuidLiteral "ca7f7bd8-2b54-508f-a542-1e24da394d95") + + it "separates reaction fields, targets, occurrences, and the router family" $ do + let reaction manager correlation target occurrence = + Reaction.deterministicReactionCommandId manager correlation sourceEventId (StreamName target) occurrence + baseline = reaction "a:b" "c" "target" 0 + baseline `shouldNotBe` reaction "a" "b:c" "target" 0 + baseline `shouldNotBe` reaction "a:b" "c" "target:other" 0 + baseline `shouldNotBe` reaction "a:b" "c" "target" 1 + baseline + `shouldNotBe` deterministicRouterCommandId "a:b" "c" sourceEventId (StreamName "target") 0 + + -- Each pair below produced one shared id under the old derivation, because + -- U+0101 and U+0001 (and U+4E2D/U+2E2D, U+6587/U+2587) agree modulo 256. + it "separates seeds the codepoint-truncating derivation collapsed" $ do + deterministicJournalId name wid 0 "\x0101" + `shouldNotBe` deterministicJournalId name wid 0 "\SOH" + deterministicJournalId name wid 0 "\x4E2D\x6587" + `shouldNotBe` deterministicJournalId name wid 0 "\x2E2D\x2587" + sleepTimerId name wid 0 "\x0101" + `shouldNotBe` sleepTimerId name wid 0 "\SOH" + generation0AwakeableId name wid "\x0101" + `shouldNotBe` generation0AwakeableId name wid "\SOH" + deterministicCommandId "counter-pm" "\x0101" sourceEventId 0 + `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 + + it "keeps the seed components positional" $ do + deterministicJournalId (WorkflowName "a") (WorkflowId "b") 0 "s" + `shouldNotBe` deterministicJournalId (WorkflowName "b") (WorkflowId "a") 0 "s" + deterministicCommandId "a" "b" sourceEventId 0 + `shouldNotBe` deterministicCommandId "b" "a" sourceEventId 0 + + around (withFreshStore fixture) $ + -- End to end: under the old derivation both step names hashed to one + -- event id, so the second append lost to the store's global event-id + -- uniqueness and this example returned @Left (DuplicateEvent Nothing)@ — + -- deterministically, on every retry, until the resume worker's + -- crash-backoff ladder marked the workflow failed. Now both steps + -- journal and the workflow completes. + it "runs a workflow whose step names collided under the old derivation" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let wfName = WorkflowName "unicodeSteps" + wfId = WorkflowId "us-1" + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow wfName wfId (collidingStepWorkflow counter) + outcome `shouldBe` Right (Completed (1, 2)) + readIORef counter `shouldReturn` 2 + Right firstRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\x0101" + firstRecorded `shouldBe` True + Right secondRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\SOH" + secondRecorded `shouldBe` True + + describe "Keiro deterministic id legacy-encoding bridge" $ do + -- These values were captured by running the pre-UTF-8 implementation at + -- 7d7a200b in an isolated worktree. Do not regenerate them from the bridge + -- implementation: they are the independent evidence that it reproduces + -- deployed identity. + let sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301") + name = WorkflowName "legacy-awake" + wid = WorkflowId "la-1" + + it "reproduces every captured process-manager command id" $ do + let commandGoldens = + [ ("order-1", 0, "ff20892c-6665-5e92-8c99-d1569d2ce629"), + ("order-1", -1, "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef"), + ("Jos\x00E9", 0, "78cbd6e1-c15f-58c3-be0e-14c861de6c85"), + ("\x4E2D\x6587", 0, "58e6ef7b-a2c9-5e46-b580-db8df2ce72c7"), + ("\x4E2D\x6587", -1, "f276cf1b-0f5c-5427-a27a-f6d4ad2ca577"), + ("\x1F600", 0, "ddc163fc-3563-5ae6-a7f8-fbe1af2712b2"), + ("\x0101", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"), + ("\SOH", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"), + ("\x0169ser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115"), + ("iser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115") + ] + for_ commandGoldens $ \(correlation, emitIndex, golden) -> + legacyDeterministicCommandId "counter-pm" correlation sourceEventId emitIndex + `shouldBe` EventId (uuidLiteral golden) + legacyDeterministicCommandId "demo-router" "g-\x4E2D\x6587" sourceEventId 0 + `shouldBe` EventId (uuidLiteral "379ebaad-62e1-5265-9605-340789ae6af7") + + it "reproduces every captured deterministic awakeable id" $ do + preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" + `shouldBe` AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b") + preUtf8Generation0AwakeableId name wid "caf\x00E9" + `shouldBe` AwakeableId (uuidLiteral "446e5258-0697-525d-af06-0c2c3911ded7") + preUtf8Generation0AwakeableId name wid "\x4E2D" + `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de") + preUtf8Generation0AwakeableId name wid "-" + `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de") + + it "keeps ASCII identity stable and moves every non-ASCII capture" $ do + legacyDeterministicCommandId "counter-pm" "order-1" sourceEventId 0 + `shouldBe` deterministicCommandId "counter-pm" "order-1" sourceEventId 0 + legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0 + `shouldBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 + legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0 + `shouldBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0 + for_ ["Jos\x00E9", "\x4E2D\x6587", "\x1F600", "\x0101", "\x0169ser"] $ \correlation -> + legacyDeterministicCommandId "counter-pm" correlation sourceEventId 0 + `shouldNotBe` deterministicCommandId "counter-pm" correlation sourceEventId 0 + legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1) + `shouldNotBe` deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1) + preUtf8Generation0AwakeableId name wid "legacy" + `shouldBe` generation0AwakeableId name wid "legacy" + preUtf8Generation0AwakeableId name wid "-" + `shouldBe` generation0AwakeableId name wid "-" + for_ ["\x627F\x8A8D", "caf\x00E9", "\x4E2D"] $ \label -> + preUtf8Generation0AwakeableId name wid label + `shouldNotBe` generation0AwakeableId name wid label + + it "documents the historical truncation collisions and their UTF-8 separation" $ do + legacyDeterministicCommandId "counter-pm" "\x0101" sourceEventId 0 + `shouldBe` legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0 + deterministicCommandId "counter-pm" "\x0101" sourceEventId 0 + `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0 + legacyDeterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0 + `shouldBe` legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0 + deterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0 + `shouldNotBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0 + preUtf8Generation0AwakeableId name wid "\x4E2D" + `shouldBe` preUtf8Generation0AwakeableId name wid "-" + generation0AwakeableId name wid "\x4E2D" + `shouldNotBe` generation0AwakeableId name wid "-" + + it "adds a legacy command probe only when the seed moved" $ do + NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "order-1" sourceEventId 0) + `shouldBe` [deterministicCommandId "counter-pm" "order-1" sourceEventId 0] + NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "\x4E2D\x6587" sourceEventId 0) + `shouldBe` [ deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0, + legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0 + ] + + it "builds one current probe for an ASCII seed" $ do + let seed = "keiro:probe:ascii" + NonEmpty.toList (deterministicIdProbes seed) + `shouldBe` [UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed)] + + it "orders the current and legacy probes for a non-ASCII seed" $ do + let seed = "keiro:probe:\x4E2D" + NonEmpty.toList (deterministicIdProbes seed) + `shouldBe` [ UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed), + UUID.V5.generateNamed UUID.V5.namespaceURL (legacySeedBytes seed) + ] + + describe "Keiro.Workflow.Sleep" $ do + -- Pure (no-DB) checks of the id/payload/step-name helpers. + it "derives a deterministic, distinct timer id" $ do + let name = WorkflowName "wf" + wid = WorkflowId "w-1" + sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a" + sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool" + (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other") + `shouldBe` False + sleepTimerId name wid 0 "sleep:cool" + `shouldBe` TimerId sleepGolden + sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool" + sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool" + + it "round-trips and recognises its timer payload" $ do + parseSleepPayload (sleepTimerPayload 2 "sleep:cool") + `shouldBe` Just ("sleep:cool", Just 2) + parseSleepPayload + ( object + [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text), + "step" Aeson..= ("sleep:legacy" :: Text) + ] + ) + `shouldBe` Just ("sleep:legacy", Nothing) + parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)]) + `shouldBe` Nothing + + it "recovers a legacy payload's generation from its deterministic timer id" $ do + let name = WorkflowName "wf" + wid = WorkflowId "w-legacy" + full = "sleep:cool" + for_ [0 .. 2] $ \gen -> + matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full) + `shouldBe` Just gen + + it "prefixes the journal step name with the reserved sleep prefix" $ + sleepStepName (StepName "cool") `shouldBe` "sleep:cool" + + around (withFreshStore fixture) $ do + it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepdemo" + wid = WorkflowId "sd-1" + journalStream = StreamName "wf:sleepdemo-sd-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + -- First run: 'a' runs, the sleep arms a timer, and the run suspends. + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- The journal holds only 'a' (no completion, no sleep:cool yet). + Right recorded1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- The durable wait is a single Scheduled timer row carrying the + -- workflow-sleep payload. + Right timerRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + timerRow `shouldSatisfy` \case + Just (status, payload) -> + status == "scheduled" + && parseSleepPayload payload == Just ("sleep:cool", Just 0) + Nothing -> False + -- Fire the timer through the routing worker (no PM fallback needed). + fireTime <- getCurrentTime + fireResult <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + case fireResult of + Right (Just timer) -> timer ^. #status `shouldBe` Firing + other -> expectationFailure ("expected a fired sleep timer, got " <> show other) + -- The row is now Fired and the journal gained sleep:cool. + Right afterFire <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst afterFire `shouldBe` Just "fired" + Right recorded2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True + _ -> False + -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs. + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + Right recorded3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True + _ -> False + + it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwait" + wid = WorkflowId "rt-1" + journalStream = StreamName "wf:sleepwait-rt-1" + clockBeforeFire <- getCurrentTime + outcome1 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome1 `shouldBe` Right Suspended + afterFirst <- readIORef counter + afterFirst `shouldBe` 1 + -- A worker whose clock is before fire_at claims nothing. + notDue <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing clockBeforeFire workflowSleepFireAction + notDue `shouldBe` Right Nothing + Right recordedMid <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _] -> True + _ -> False + -- Wait out the one-second delay, then the worker fires it. + threadDelay 1_200_000 + afterDelay <- getCurrentTime + fired <- + Store.runStoreIO storeHandle $ + runTimerWorker Nothing afterDelay workflowSleepFireAction + fired `shouldSatisfy` \case + Right (Just _) -> True + _ -> False + Right recordedWoken <- + Store.runStoreIO storeHandle $ + Store.readStreamForward journalStream (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken) + `shouldSatisfy` \case + Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True + _ -> False + outcome2 <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + outcome2 `shouldBe` Right (Completed (1, 2)) + afterSecond <- readIORef counter + afterSecond `shouldBe` 2 + + it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeponce" + wid = WorkflowId "so-1" + TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300) + Right (Just firstFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered summary `shouldBe` 0 + Right (Just secondFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerFireAtStmt + secondFireAt `shouldBe` firstFireAt + readIORef counter >>= (`shouldBe` 1) + + it "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleep-wake-stable" + wid = WorkflowId "sws-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) + Right (Just firstWakeAfter) <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + + Right rearmed <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered rearmed `shouldBe` 1 + Right (Just secondWakeAfter) <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + secondWakeAfter `shouldBe` firstWakeAfter + + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right clearedWakeAfter <- + Store.runStoreIO storeHandle $ + workflowWakeAfter name wid + clearedWakeAfter `shouldBe` Nothing + + Right resumed <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered resumed `shouldBe` 1 + completed resumed `shouldBe` 1 + readIORef counter >>= (`shouldBe` 2) + + it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepwakeafter" + wid = WorkflowId "swa-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + now <- getCurrentTime + Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + case mWakeAfter of + Nothing -> expectationFailure "expected wake_after" + Just wakeAfter -> wakeAfter `shouldSatisfy` (> now) + Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now + early `shouldBe` [] + Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now) + due `shouldBe` [("swa-1", "sleepwakeafter")] + + it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepquiet" + wid = WorkflowId "sq-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60)) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + Right s1 <- pass + Right s2 <- pass + Right s3 <- pass + map discovered [s1, s2, s3] `shouldBe` [0, 0, 0] + readIORef counter >>= (`shouldBe` 1) + + it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do + let name = WorkflowName "sleepmissingrow" + wid = WorkflowId "smr-1" + body = sleepNamed (StepName "wait") 60 >> pure () + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldReturn` Right Suspended + + it "fires a sleep whose instance row is missing after an arm crash" $ \storeHandle -> do + let name = WorkflowName "sleep-missing-fire" + wid = WorkflowId "smf-1" + body = sleepNamed (StepName "wait") 0 + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right resolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 "sleep:wait" + resolved `shouldBe` True + Right (Just recovered) <- + Store.runStoreIO storeHandle $ + Instance.lookupInstance name wid + recovered ^. #status `shouldBe` Instance.WfRunning + Store.runStoreIO storeHandle (runWorkflow name wid body) + `shouldReturn` Right (Completed ()) + + it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleepactive" + wid = WorkflowId "sa-1" + registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1) + threadDelay 1_200_000 + Right boundaryPass <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered boundaryPass `shouldBe` 1 + fireTime <- getCurrentTime + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing) + Right completionPass <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + discovered completionPass `shouldBe` 1 + completed completionPass `shouldBe` 1 + readIORef counter >>= (`shouldBe` 2) + + it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleeproll" + wid = WorkflowId "sr-1" + registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter)) + drive 0 = expectationFailure "rolling sleep did not complete" + drive n = do + Right summary <- + Store.runStoreIO storeHandle $ + resumeWorkflowsOnce defaultWorkflowResumeOptions registry + now <- getCurrentTime + _ <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + if completed summary == 1 + then pure () + else drive (n - 1) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter) + drive (12 :: Int) + readIORef counter >>= (`shouldBe` 3) + + describe "Keiro.Timer batched drain" $ around (withFreshStore fixture) $ do + -- The single-claim worker drains a backlog at one timer per invocation, so + -- ten due sleeps take ten poll ticks and the last workflow wakes ticks late. + -- One drain pass wakes them all, with one requeue-and-gauge preamble instead + -- of ten. + it "drains a mixed backlog of sleeps and process-manager timers in one pass" $ \storeHandle -> do + firedPm <- newIORef ([] :: [Text]) + let sleepers = [1 .. 4 :: Int] + sleeperName = WorkflowName "drain-sleeper" + sleeperId i = WorkflowId ("ds-" <> Text.pack (show i)) + for_ sleepers $ \i -> do + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow sleeperName (sleeperId i) (sleepNamed (StepName "wait") 0) + outcome `shouldBe` Right Suspended + for_ [1 .. 6 :: Int] $ \i -> + Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i))) + `shouldReturn` Right () + now <- addUTCTime 1 <$> getCurrentTime + Right drained <- + Store.runStoreIO storeHandle $ + drainWorkflowSleepTimers Nothing now 20 $ \row -> do + liftIO (modifyIORef' firedPm (row ^. #correlationId :)) + pure (Just (EventId sampleUuid2)) + drained `shouldBe` 10 + -- Every sleep actually woke: the completion is journaled, not merely + -- claimed. + for_ sleepers $ \i -> do + Right woke <- Store.runStoreIO storeHandle $ stepExists sleeperName (sleeperId i) 0 "sleep:wait" + woke `shouldBe` True + readIORef firedPm >>= \fired -> length fired `shouldBe` 6 + -- Nothing is left claimable. + Right leftovers <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 (\_ -> pure Nothing) + leftovers `shouldBe` 0 + + it "stops at the batch limit and leaves the rest claimable" $ \storeHandle -> do + for_ [1 .. 10 :: Int] $ \i -> + Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i))) + `shouldReturn` Right () + now <- addUTCTime 1 <$> getCurrentTime + let fireOne _ = pure (Just (EventId sampleUuid2)) + Right firstBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 3 fireOne + firstBatch `shouldBe` 3 + Right restBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne + restBatch `shouldBe` 7 + -- A limit of zero still runs the preamble but claims nothing, and an + -- empty backlog costs exactly what a single-claim pass costs. + Right noneLeft <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne + noneLeft `shouldBe` 0 + + describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do + it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleep-generation-pin" + wid = WorkflowId "sgp-1" + full = "sleep:cool" + TimerId generationZeroTimerId = sleepTimerId name wid 0 full + TimerId generationOneTimerId = sleepTimerId name wid 1 full + body = do + seed <- restoreSeed (0 :: Int) + _ <- step (StepName "work") (liftIO (incrementAndRead counter)) + if seed == 0 + then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int) + else sleepNamed (StepName "cool") 3600 >> pure seed + + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + claimTime <- getCurrentTime + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime + claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId + Right (Just _) <- + Store.runStoreIO storeHandle $ + workflowSleepFireAction claimed + + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right (Just generationOneFireAt) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerFireAtStmt + + requeueTime <- getCurrentTime + Right requeued <- + Store.runStoreIO storeHandle $ + requeueStuckTimers 0 (addUTCTime 1 requeueTime) + requeued `shouldBe` 1 + Right (Just staleFire) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing) + staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId + + Right generationOneResolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 1 full + generationOneResolved `shouldBe` False + Right (Just instanceRow) <- + Store.runStoreIO storeHandle $ + Instance.lookupInstance name wid + instanceRow ^. #status `shouldBe` Instance.WfSuspended + Right generationZeroStatus <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationZeroTimerId sleepTimerStatusStmt + fmap fst generationZeroStatus `shouldBe` Just "fired" + Right generationOneStatus <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerStatusStmt + fmap fst generationOneStatus `shouldBe` Just "scheduled" + Right (Just generationOneFireAtAfter) <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement generationOneTimerId sleepTimerFireAtStmt + generationOneFireAtAfter `shouldBe` generationOneFireAt + readIORef counter >>= (`shouldBe` 2) + + describe "Keiro.Workflow wake-lifecycle visibility" $ around (withFreshStore fixture) $ do + -- Cancelling an awakeable writes no journal entry, so it is the one + -- wake-source lifecycle transition that would otherwise leave the owning + -- instance row untouched. It must still leave the workflow discoverable, or + -- the workflow can never reach its await arm to observe the cancellation. + it "flips the owner instance to running when its awakeable is cancelled" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "cancel-visible" + wid = WorkflowId "cv-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + parked ^. #status `shouldBe` Instance.WfSuspended + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + woken ^. #status `shouldBe` Instance.WfRunning + woken ^. #generation `shouldBe` 0 + now <- getCurrentTime + Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + unfinished `shouldBe` [("cv-1", "cancel-visible")] + -- The pass re-invokes the workflow; its await arm sees the cancelled row + -- and throws, which the worker records as a crash attempt. + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) + Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + crashed ^. #attempts `shouldBe` 1 + fmap Text.unpack (crashed ^. #lastError) + `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") + + -- Only the first arm writes wake_after, so a stale re-fire that clears it + -- erases a hint nothing will rewrite. Only a fresh append is a successful + -- fire in ADR 7's sense. + it "leaves a newer sleep's wake hint intact when a stale timer re-fires" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "sleep-refire" + wid = WorkflowId "sr-2" + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter) + claimTime <- getCurrentTime + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime + claimed ^. #timerId `shouldBe` sleepTimerId name wid 0 (sleepStepName (StepName "first")) + -- Fire the first sleep, then "crash" before the worker marks the timer + -- fired: the row stays in `firing` and is requeued below. + Right firstFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed + firstFire `shouldSatisfy` isJust + Right cleared <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + cleared `shouldBe` Nothing + -- The next run replays past the first sleep and arms the second one, + -- whose insert writes the live wake hint. + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter) + Right (Just liveHint) <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + liveHint `shouldSatisfy` (> claimTime) + requeueTime <- getCurrentTime + Right requeued <- + Store.runStoreIO storeHandle $ requeueStuckTimers 0 (addUTCTime 1 requeueTime) + requeued `shouldBe` 1 + Right (Just stale) <- + Store.runStoreIO storeHandle $ claimDueTimer (addUTCTime 2 requeueTime) + (stale ^. #timerId) `shouldBe` (claimed ^. #timerId) + Right staleFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction stale + -- Still idempotent: the re-fire reports the same deterministic event id. + staleFire `shouldBe` firstFire + Right hintAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + hintAfter `shouldBe` Just liveHint + readIORef counter >>= (`shouldBe` 1) + + describe "Keiro.Workflow exact discovery" $ around (withFreshStore fixture) $ do + it "hides a workflow parked on an awakeable until it is signalled" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "quiet-awk" + wid = WorkflowId "qa-1" + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + parkedAt <- getCurrentTime + Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) + parked `shouldBe` [] + -- The whole point: a parked workflow costs a pass nothing at all. + Right idle <- pass + idle `shouldBe` emptyResumeSummary + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + wokenAt <- getCurrentTime + Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + woken `shouldBe` [("qa-1", "quiet-awk")] + Right finish <- pass + (discovered finish, completed finish) `shouldBe` (1, 1) + doneAt <- getCurrentTime + Right afterCompletion <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds doneAt) + afterCompletion `shouldBe` [] + + -- The parent is invisible while it waits, but the freshly spawned child is + -- discovered from the instance row spawnChild writes in the spawn step's + -- transaction — which is why the resume worker no longer needs a separate + -- findRunningChildIds seed. + it "hides a parent parked on a child while still discovering the zero-step child" $ \storeHandle -> do + let parentName = WorkflowName "quiet-parent" + parentWid = WorkflowId "qp-1" + childName = WorkflowName "ship" + childWid = WorkflowId "ship-quiet" + registry = Map.singleton parentName (WorkflowDef (\_ -> parentWorkflow childWid)) + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentWid (parentWorkflow childWid) + parkedAt <- getCurrentTime + Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) + parked `shouldBe` [("ship-quiet", "ship")] + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions childName childWid shipWorkflow + wokenAt <- getCurrentTime + Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + woken `shouldBe` [("qp-1", "quiet-parent")] + Right finish <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + (discovered finish, completed finish) `shouldBe` (1, 1) + + -- Wake-wins ordering. markInstanceSuspendedAwaiting is exactly the write a + -- run performs after its (now stale) index miss, so calling it directly + -- after a signal reproduces the race deterministically. + it "writes running when the wake landed before the suspend write" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "race-wake-first" + wid = WorkflowId "rwf-1" + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + Right () <- + Store.runStoreIO storeHandle $ + Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + arbitrated ^. #status `shouldBe` Instance.WfRunning + wokenAt <- getCurrentTime + Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + woken `shouldBe` [("rwf-1", "race-wake-first")] + Right finish <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + completed finish `shouldBe` 1 + + -- Suspend-wins ordering: the wake, queued behind the suspend write on the + -- same per-step lock, flips the instance itself. + it "flips a suspended instance to running when the wake lands after the suspend write" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "race-suspend-first" + wid = WorkflowId "rsf-1" + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right () <- + Store.runStoreIO storeHandle $ + Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + Right (Just parkedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + parkedRow ^. #status `shouldBe` Instance.WfSuspended + parkedAt <- getCurrentTime + Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) + invisible `shouldBe` [] + Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + Right (Just wokenRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + wokenRow ^. #status `shouldBe` Instance.WfRunning + Right finish <- + Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + completed finish `shouldBe` 1 + + it "stays discoverable when a cancel lands before the stale suspend write" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "race-cancel-first" + wid = WorkflowId "rcf-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid + Right () <- + Store.runStoreIO storeHandle $ + Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + arbitrated ^. #status `shouldBe` Instance.WfRunning + wokenAt <- getCurrentTime + Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + woken `shouldBe` [("rcf-1", "race-cancel-first")] + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) + Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + crashed ^. #attempts `shouldBe` 1 + fmap Text.unpack (crashed ^. #lastError) + `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") + + it "flips a suspended instance to running when the cancel lands after the suspend write" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "race-cancel-second" + wid = WorkflowId "rcs-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef)) + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right () <- + Store.runStoreIO storeHandle $ + Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + parked ^. #status `shouldBe` Instance.WfSuspended + parkedAt <- getCurrentTime + Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt) + invisible `shouldBe` [] + Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid + Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + woken ^. #status `shouldBe` Instance.WfRunning + wokenAt <- getCurrentTime + Right discoveredNow <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt) + discoveredNow `shouldBe` [("rcs-1", "race-cancel-second")] + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0) + Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + crashed ^. #attempts `shouldBe` 1 + fmap Text.unpack (crashed ^. #lastError) + `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled") + + it "surfaces a due sleep through the wake hint and a fired sleep through running" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "quiet-sleep" + wid = WorkflowId "qs-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60) + now <- getCurrentTime + Right early <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now) + early `shouldBe` [] + -- Due, but the timer worker has not fired it yet: the suspended arm. + let dueAt = addUTCTime 61 now + Right due <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds dueAt) + due `shouldBe` [("qs-1", "quiet-sleep")] + Right (Just _) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing dueAt (\_ -> pure Nothing) + Right (Just fired) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + fired ^. #status `shouldBe` Instance.WfRunning + Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + hint `shouldBe` Nothing + -- Now discovered through the running arm, with no hint left to expire. + firedAt <- getCurrentTime + Right visible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds firedAt) + visible `shouldBe` [("qs-1", "quiet-sleep")] + + -- A crashed workflow stays 'running', so exact discovery keeps returning it; + -- what paces the retry is claimInstance's next_attempt_at gate, which is + -- reported distinctly from a live foreign lease. + it "keeps a crashed workflow discovered while its backoff gate paces retries" $ \storeHandle -> do + let name = WorkflowName "crash-visible" + wid = WorkflowId "cvz-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 3 + & #logEvent + .~ const (pure ()) + registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) + seededAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) + Right first <- pass + (discovered first, resumed first, failed first) `shouldBe` (1, 1, 0) + Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + crashed ^. #status `shouldBe` Instance.WfRunning + crashed ^. #attempts `shouldBe` 1 + Right second <- pass + (discovered second, paced second, leaseSkipped second) `shouldBe` (1, 1, 0) + + it "a bounded drain loop terminates over a pool that cannot advance" $ \storeHandle -> do + let crashName = WorkflowName "drain-crash" + crashWid = WorkflowId "drain-crash-1" + ghostName = WorkflowName "drain-ghost" + ghostWid = WorkflowId "drain-ghost-1" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 3 + & #logEvent + .~ const (pure ()) + registry = + Map.singleton + crashName + (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) + drain 0 acc = pure acc + drain n acc = do + Right summary <- pass + if advanced summary > 0 + then drain (n - 1 :: Int) (acc <> [summary]) + else pure (acc <> [summary]) + seededAt <- getCurrentTime + for_ [(crashName, crashWid), (ghostName, ghostWid)] $ \(name, wid) -> do + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt) + pure () + passes <- drain 10 [] + length passes `shouldBe` 1 + case passes of + [summary] -> do + (discovered summary, resumed summary, unknownName summary, advanced summary) + `shouldBe` (2, 1, 1, 0) + unregisteredNames summary `shouldBe` Set.singleton "drain-ghost" + other -> expectationFailure ("expected one drain pass, got " <> show other) + Right blocked <- pass + (discovered blocked, paced blocked, unknownName blocked, advanced blocked) + `shouldBe` (2, 1, 1, 0) + unregisteredNames blocked `shouldBe` Set.singleton "drain-ghost" + + it "a bounded drain loop terminates over a due sleep with no timer worker" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "drain-due-sleep" + wid = WorkflowId "dds-1" + opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ()) + registry = + Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") (-1))) + pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry) + drain 0 acc = pure acc + drain n acc = do + Right summary <- pass + if advanced summary > 0 + then drain (n - 1 :: Int) (acc <> [summary]) + else pure (acc <> [summary]) + -- Arm the sleep with an already-due fire time. No timer worker ever fires it. + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") (-1)) + readIORef counter `shouldReturn` 1 + passes <- drain 5 [] + length passes `shouldBe` 1 + case passes of + [summary] -> + (discovered summary, resumed summary, stillSuspended summary, advanced summary, sleepDue summary) + `shouldBe` (1, 1, 1, 0, 1) + other -> expectationFailure ("expected one drain pass, got " <> show other) + Right blocked <- pass + (discovered blocked, stillSuspended blocked, advanced blocked, sleepDue blocked) + `shouldBe` (1, 1, 0, 1) + -- Replay-only: neither step body re-ran. + readIORef counter `shouldReturn` 1 + -- The candidate is still discoverable, blocked on the timer worker rather than lost. + Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + row ^. #status `shouldBe` Instance.WfSuspended + Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid + hint `shouldSatisfy` isJust + + describe "Keiro.Workflow terminal boundaries" $ around (withFreshStore fixture) $ do + -- The asymmetry this closes: cancellation stopped a run at the next step + -- boundary, terminal failure did not. Before the append transaction checked + -- both markers, this workflow ran step "two" and reported Completed. + it "stops at the next step boundary when a workflow is failed mid-run" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "self-fail" + wid = WorkflowId "sf-1" + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (selfFailingWorkflow name wid counter) + outcome `shouldBe` Right Keiro.Workflow.Failed + -- Step one's action ran (its side effect is at-least-once at boundaries); + -- step two's never did. + readIORef counter `shouldReturn` 1 + -- Step one's own append is the one the in-transaction check has to refuse: + -- the marker landed *inside* that action, after the pre-action probe had + -- already passed. Nothing more is journaled into a terminal workflow. + Right recordedOne <- Store.runStoreIO storeHandle $ stepExists name wid 0 "one" + recordedOne `shouldBe` False + Right recordedTwo <- Store.runStoreIO storeHandle $ stepExists name wid 0 "two" + recordedTwo `shouldBe` False + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:self-fail-sf-1") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case WorkflowFailed {} -> True; _ -> False) decoded `shouldBe` True + any (\case StepRecorded "two" _ _ -> True; _ -> False) decoded `shouldBe` False + + it "declines an ordinary append into a cancelled workflow without erroring" $ \storeHandle -> do + let name = WorkflowName "refuse-cancelled" + wid = WorkflowId "rc-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (StepRecorded "late" (toJSON True) now) + Right present <- Store.runStoreIO storeHandle $ stepExists name wid 0 "late" + present `shouldBe` False + + -- A wake source settles its own durable row even when it cannot deliver: + -- the promise is resolved, the journal entry is not written. + it "completes an awakeable owned by a failed workflow but journals nothing" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "refuse-signal" + wid = WorkflowId "rs-1" + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + failedAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt) + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Completed + Right delivered <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + delivered `shouldBe` False + + -- The refusal reads the derived failure-marker index row, which + -- resurrection deletes, so a revived workflow accepts deliveries again by + -- construction (ADR 8: failure history is immutable, derived state is + -- revivable). + it "accepts a wake append again after the workflow is resurrected" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "revive-delivery" + wid = WorkflowId "rd-1" + Right Suspended <- + Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + failedAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt) + Right Instance.WorkflowResurrected <- + Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right delivered <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid) + delivered `shouldBe` True + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldReturn` Right (Completed "ok!") + + -- Defense in depth for the sleep fire: its instance-status guard cannot see + -- a cancellation whose instance row was already collected, but the append + -- transaction still refuses. The timer is marked fired regardless, so it is + -- not requeued forever against a workflow that will never accept it. + it "marks a sleep timer fired without delivering into a cancelled workflow" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "refuse-sleep" + wid = WorkflowId "rsl-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0) + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled cancelledAt) + -- Partial GC: the instance row is gone, so the fire action's terminal + -- guard finds nothing and proceeds to the append. + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("rsl-1", "refuse-sleep") deleteWorkflowInstanceStmt + claimTime <- getCurrentTime + Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime + Right fired <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed + fired `shouldSatisfy` isJust + Right delivered <- Store.runStoreIO storeHandle $ stepExists name wid 0 "sleep:wait" + delivered `shouldBe` False + + describe "Keiro.Workflow.Awakeable" $ do + -- Pure (no-DB) check of the frozen generation-0 compatibility derivation. + it "reproduces a stable, label-sensitive generation-0 AwakeableId" $ do + let aid1 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aid2 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval" + aidOther = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "other" + awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279" + aid1 `shouldBe` aid2 + (aid1 == aidOther) `shouldBe` False + aid1 `shouldBe` AwakeableId awakeableGolden + + around (withFreshStore fixture) $ do + it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do + let aidA = awakeableIdToUuid (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "a") + aidB = awakeableIdToUuid (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "b") + now <- getCurrentTime + Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do + Awk.registerAwakeableTx aidA "sch" "1" + Awk.registerAwakeableTx aidB "sch" "1" + Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingCount `shouldBe` 2 + Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA ^. #status `shouldBe` Awk.Pending + rowA ^. #payload `shouldBe` Nothing + -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op. + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA + rowA' ^. #status `shouldBe` Awk.Completed + rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text)) + -- Cancel the still-pending B; both rows are now resolved. The guarded + -- UPDATE returns the owner coordinates so the caller can flip the + -- owning instance row in the same transaction. + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.cancelAwakeableTx aidB + cancelled `shouldBe` Just ("sch", "1") + Right reCancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.cancelAwakeableTx aidB + reCancelled `shouldBe` Nothing + Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingAfter `shouldBe` 0 + + it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome1 `shouldBe` Right Suspended + aid <- readRequiredAwakeableId aidRef + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Pending + row ^. #payload `shouldBe` Nothing + Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables + pendingNow `shouldBe` 1 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded) + `shouldSatisfy` \case + Right [StepRecorded stepName value _] -> + stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid + _ -> False + + it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "approval" + wid = WorkflowId "wf1" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Completed + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right afterSignal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s r _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text) + _ -> False + outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + outcome2 `shouldBe` Right (Completed "ok!") + Right afterResume <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume) + `shouldSatisfy` \case + Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> + allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep + _ -> False + + it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "idem" + wid = WorkflowId "wf-i" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text) + again `shouldBe` False + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text)) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "cancelwf" + wid = WorkflowId "wf2" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid) + row ^. #status `shouldBe` Awk.Cancelled + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldThrow` (== WorkflowAwakeableCancelled aid) + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case WorkflowCompleted {} -> True; _ -> False) decoded `shouldBe` False + + it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash" + wid = WorkflowId "wf3" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + -- Simulate "row completed but the journal append did not happen" by + -- completing the row directly, bypassing signalAwakeable's journal write. + now <- getCurrentTime + Right completedRow <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + completedRow `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` [] + -- A re-signal with the same payload returns False (already completed) but + -- repairs the missing journal entry from the stored payload. + Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text) + repaired `shouldBe` False + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + + it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "crash-arm" + wid = WorkflowId "wf4" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + let awkStep = "awk:" <> awakeableIdText aid + now <- getCurrentTime + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now + repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + repairedRun `shouldBe` Right Suspended + Right repairedJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100 + Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal)) + [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)] + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "fresh-awake" + wid = WorkflowId "fa-1" + forged = generation0AwakeableId name wid "approval" + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + real <- readRequiredAwakeableId aidRef + real `shouldNotBe` forged + Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text) + forgedSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + stillSuspended `shouldBe` Suspended + Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text) + realSignal `shouldBe` True + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "legacy-awake" + wid = WorkflowId "la-1" + legacy = generation0AwakeableId name wid "approval" + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + adopted <- readRequiredAwakeableId aidRef + adopted `shouldBe` legacy + Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "adopts a pre-UTF-8 generation-0 row for a non-ASCII label" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "legacy-awake" + wid = WorkflowId "la-1" + legacy = AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b") + preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" `shouldBe` legacy + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid) + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef) + adopted <- readRequiredAwakeableId aidRef + adopted `shouldBe` legacy + Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef) + completed `shouldBe` Right (Completed "ok!") + + it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do + idsRef <- newIORef [] + let name = WorkflowName "awake-roll" + wid = WorkflowId "ar-1" + body = rollingAwakeableWorkflow idsRef + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids1 <- readIORef idsRef + [firstAid] <- pure ids1 + Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text) + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + ids2 <- readIORef idsRef + case ids2 of + [firstAgain, secondAid] -> do + firstAgain `shouldBe` firstAid + secondAid `shouldNotBe` firstAid + Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text) + staleSignal `shouldBe` False + Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body + stillSuspended `shouldBe` Suspended + Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text) + completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body + completed `shouldBe` Right (Completed "second") + other -> expectationFailure ("expected two awakeable ids, got " <> show other) + + describe "Keiro.Workflow awakeable registration" $ around (withFreshStore fixture) $ do + it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "awakeable-signal-gap" + wid = WorkflowId "asg-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (publishAwakeableBeforeAwait aidRef) + aid <- readRequiredAwakeableId aidRef + Right (Just pendingRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + pendingRow ^. #status `shouldBe` Awk.Pending + + Right signalled <- + Store.runStoreIO storeHandle $ + signalAwakeable aid ("ok" :: Text) + signalled `shouldBe` True + Right (Just completedRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + completedRow ^. #status `shouldBe` Awk.Completed + + let unknown = + AwakeableId + (uuidLiteral "00000000-0000-0000-0000-0000000002f2") + Right unknownSignal <- + Store.runStoreIO storeHandle $ + signalAwakeable unknown ("forged" :: Text) + unknownSignal `shouldBe` False + + completed <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (awaitPublishedAwakeable aidRef) + completed `shouldBe` Right (Completed "ok") + + describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do + it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do + aidRef <- newIORef Nothing + let name = WorkflowName "awakeable-cancel-race" + wid = WorkflowId "acr-1" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (approvalFlowWithId aidRef) + aid <- readRequiredAwakeableId aidRef + Right (Just stalePendingRow) <- + Store.runStoreIO storeHandle $ + Awk.lookupAwakeable (awakeableIdToUuid aid) + Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid + cancelled `shouldBe` True + Right signalled <- + Store.runStoreIO storeHandle $ + signalAwakeableFrom stalePendingRow ("late" :: Text) + signalled `shouldBe` False + Right recorded <- + Store.runStoreIO storeHandle $ + stepExists + name + wid + 0 + (awakeableStepPrefix <> awakeableIdText aid) + recorded `shouldBe` False + Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef)) + `shouldThrow` (== WorkflowAwakeableCancelled aid) + + describe "Keiro.Workflow.Child" $ do + -- M2: the reserved spawn/result step-name derivations are stable. + it "derives the child spawn and result step names" $ do + childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1" + childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result" + + -- M3(a): the new terminal journal constructors round-trip through the codec. + it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do + let t = UTCTime (ModifiedJulianDay 0) 0 + rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev) + rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t) + rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t) + + around (withFreshStore fixture) $ do + -- M1: the keiro_workflow_children table and its schema helpers. + it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result" + Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship" + row ^. #status `shouldBe` Child.Running + row ^. #parentId `shouldBe` "p-1" + row ^. #parentName `shouldBe` "parent" + row ^. #awaitStep `shouldBe` "child:c-1:result" + now <- getCurrentTime + Right firstComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now + firstComplete `shouldBe` True + Right secondComplete <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now + secondComplete `shouldBe` False + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result" + Right cancelled <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "c-2" "ship" + cancelled `shouldBe` True + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent" + map (^. #childId) kids `shouldBe` ["c-1", "c-2"] + Right active <- Store.runStoreIO storeHandle Child.countActiveChildren + active `shouldBe` (0 :: Int) + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship" + st `shouldBe` Just Child.ChildCompleted + + -- M4: spawn -> drive the child (with the completion hook) -> resume parent. + it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do + let childWid = WorkflowId "ship-1" + suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + suspended `shouldBe` Right Suspended + Right parentJournal1 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1)) + decoded1 `shouldSatisfy` \case + [StepRecorded "child:ship-1" _ _] -> True + _ -> False + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow ^. #status `shouldBe` Child.Running + childRow ^. #parentId `shouldBe` "p1" + childRow ^. #parentName `shouldBe` "parent" + childRow ^. #awaitStep `shouldBe` "child:ship-1:result" + -- 2) drive the child through runChildWorkflow (propagates on completion). + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10 + traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal) + `shouldSatisfy` \case + Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True + _ -> False + Right parentJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2)) + [r | StepRecorded "child:ship-1:result" r _ <- decoded2] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship" + childRow2 ^. #status `shouldBe` Child.ChildCompleted + -- 3) resume the parent: it replays past awaitChild and completes. + resumed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid) + resumed `shouldBe` Right (Completed "done:packed+labelled") + Right parentJournal3 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10 + Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3)) + any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True + any (\case WorkflowCompleted {} -> True; _ -> False) decoded3 `shouldBe` True + + it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do + let childWid = WorkflowId "ship-crash" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + now <- getCurrentTime + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now + transitioned `shouldBe` True + Right beforeRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` [] + repaired <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + repaired `shouldBe` Right Suspended + Right afterRepair <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10 + Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair)) + [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded] + `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]] + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid) + completed `shouldBe` Right (Completed "done:packed+labelled") + + -- M5: re-invoking the parent does not re-spawn the child (crash survival). + it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do + let childWid = WorkflowId "ship-2" + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship" + let createdAt0 = beforeRow ^. #createdAt + s2 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid) + s2 `shouldBe` Right Suspended + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1 + Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent" + length kids `shouldBe` 1 + map (^. #createdAt) kids `shouldBe` [createdAt0] + + -- M5: cancelling a child stops it and makes the parent's awaitChild throw. + it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child" + h = ChildHandle (WorkflowName "ship") childWid + s1 <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid) + s1 `shouldBe` Right Suspended + Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h + cancelled `shouldBe` True + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship" + st `shouldBe` Just Child.ChildCancelled + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + -- driving the child returns Cancelled and runs none of its steps. + childOutcome <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal2 <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10 + Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2)) + any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False + -- re-invoking the parent throws WorkflowChildCancelled. + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)) + `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid) + + it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-crash" + h = ChildHandle (WorkflowName "ship") childWid + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid) + Right transitioned <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-crash" "ship" + transitioned `shouldBe` True + Right retried <- Store.runStoreIO storeHandle $ cancelChild h + retried `shouldBe` False + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do + let childWid = WorkflowId "cancel-child-drive" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid) + Right True <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Child.markChildCancelledTx "cancel-child-drive" "ship" + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right Keiro.Workflow.Cancelled + Right childJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10 + Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)) + any (\case WorkflowCancelled {} -> True; _ -> False) childDecoded `shouldBe` True + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded] + `shouldBe` [object ["cancelled" Aeson..= True]] + + it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do + let childWid = WorkflowId "json-cancelled-object" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow + childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + completed <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid) + completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True])) + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded] + `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]] + + it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do + let childWid = WorkflowId "decode-child" + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid) + Store.runStoreIO + storeHandle + (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int))) + `shouldReturn` Right () + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowStepDecodeError key _ -> key == "child:decode-child:result" + _ -> False + + it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do + let childWid = WorkflowId "failed-child" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) + ] + opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship" + childRow ^. #status `shouldBe` Child.ChildFailed + Store.runStoreIO + storeHandle + (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)) + `shouldThrow` \case + WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason -> + "SimulatedCrash" `Text.isInfixOf` reason + _ -> False + + it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do + counter <- newIORef 0 + let name = WorkflowName "self-cancel" + wid = WorkflowId "sc1" + outcome <- + Store.runStoreIO storeHandle $ + runWorkflow name wid (selfCancellingWorkflow name wid counter) + outcome `shouldBe` Right Keiro.Workflow.Cancelled + readIORef counter `shouldReturn` 2 + Right recorded <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10 + Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)) + any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False + + -- EP-42 worker-driven variant: the resume worker drives both parent and + -- child from a registry, selecting childCompletionHook for the child and + -- union-discovering the zero-step child. + it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do + let childWid = WorkflowId "ship-3" + registry = + Map.fromList + [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow)) + ] + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid) + let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry) + Right _ <- drive + Right _ <- drive + Right _ <- drive + Right parentJournal <- + Store.runStoreIO storeHandle $ + Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10 + Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal)) + any (\case WorkflowCompleted {} -> True; _ -> False) parentDecoded `shouldBe` True + Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship" + childRow ^. #status `shouldBe` Child.ChildCompleted + + it "attaches to a completed child after continueAsNew" $ \storeHandle -> do + let childWid = WorkflowId "ship-rotated" + parentName = WorkflowName "parent-rotating" + parentId = WorkflowId "p-rotating" + body = rotatingParentWorkflow childWid + Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + childOutcome <- + Store.runStoreIO storeHandle $ + runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow + childOutcome `shouldBe` Right (Completed "packed+labelled") + Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + repair `shouldBe` Right Suspended + completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body + completed `shouldBe` Right (Completed "packed+labelled") + + describe "Keiro.Workflow.Child durable failed delivery" $ around (withFreshStore fixture) $ do + it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do + let childWid = WorkflowId "failed-before-rotation" + parentName = WorkflowName "parent-failure-rotation" + parentId = WorkflowId "p-failure-rotation" + registry = + Map.fromList + [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)), + (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text))) + ] + opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (failedChildBeforeRotation childWid) + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + failed summary `shouldBe` 1 + Right (Just childRow) <- + Store.runStoreIO storeHandle $ + Child.lookupChild "failed-before-rotation" "ship" + childRow ^. #status `shouldBe` Child.ChildFailed + childRow ^. #failureReason + `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`) + Right failedOnGenerationZero <- + Store.runStoreIO storeHandle $ + stepExists + parentName + parentId + 0 + (childResultStepName childWid) + failedOnGenerationZero `shouldBe` True + + Right ContinuedAsNew <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (rotatePastFailedChild childWid) + Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId + generation `shouldBe` 1 + Right failedOnGenerationOne <- + Store.runStoreIO storeHandle $ + stepExists + parentName + parentId + 1 + (childResultStepName childWid) + failedOnGenerationOne `shouldBe` False + + delivered <- + Store.runStoreIO storeHandle $ + runWorkflow parentName parentId (catchFailedChildAfterRotation childWid) + delivered `shouldSatisfy` \case + Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason + _ -> False + + describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do + it "deletes terminal workflow data after retention" $ \storeHandle -> do + let name = WorkflowName "gc-basic" + wid = WorkflowId "gb-1" + gcStreamName = workflowGenerationStreamName name wid 0 + aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1") + timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2") + counter <- newIORef (0 :: Int) + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflowWith + (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal) + name + wid + (demoWorkflow counter) + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Awk.registerAwakeableTx aid "gc-basic" "gb-1" + Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt + Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1) + Right freshSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + now + WorkflowGc.WorkflowGcPolicy {retention = 3600, batchSize = 10} + freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} + Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right deletedSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName + Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1" + afterCounts `shouldBe` (0, 0, 0, 0, 0, 0) + + it "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let name = WorkflowName "gc-scheduled-sleep" + wid = WorkflowId "gss-1" + journalStream = workflowGenerationStreamName name wid 0 + TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait" + body = do + _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter)) + sleepNamed (StepName "wait") 3600 + Right Suspended <- + Store.runStoreIO storeHandle $ + runWorkflow name wid body + Right timerBeforeGc <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst timerBeforeGc `shouldBe` Just "scheduled" + + cancelledAt <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry name wid (WorkflowCancelled cancelledAt) + gcClock <- getCurrentTime + Right collected <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 gcClock) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1} + + Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + Right timerAfterGc <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + timerAfterGc `shouldBe` Nothing + + Right noClaim <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing) + noClaim `shouldBe` Nothing + Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + readIORef counter >>= (`shouldBe` 1) + + it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do + let name = WorkflowName "gc-terminal-fire" + wid = WorkflowId "gtf-1" + full = "sleep:wait" + timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full + journalStream = workflowGenerationStreamName name wid 0 + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing + void $ + scheduleTimerOnceTx + TimerRequest + { timerId, + processManagerName = "gc-terminal-fire", + correlationId = "gtf-1", + fireAt = now, + payload = sleepTimerPayload 0 full + } + Right (Just claimed) <- + Store.runStoreIO storeHandle $ + runWorkflowTimerWorker Nothing now (\_ -> pure Nothing) + claimed ^. #timerId `shouldBe` timerId + Right terminalTimer <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement timerUuid sleepTimerStatusStmt + fmap fst terminalTimer `shouldBe` Just "cancelled" + Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream + Right resolved <- + Store.runStoreIO storeHandle $ + stepExists name wid 0 full + resolved `shouldBe` False + + it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do + let parentName = WorkflowName "gc-live-parent" + parentId = WorkflowId "gp-1" + childName = WorkflowName "gc-child" + childId = WorkflowId "gc-1" + now <- getCurrentTime + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ do + Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing + Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result" + void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now) + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry childName childId (WorkflowCompleted now) + Right held <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + held `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 0, deleted = 0} + Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0) + childStillThere `shouldSatisfy` isJust + Right () <- + Store.runStoreIO storeHandle $ + appendJournalEntry parentName parentId (WorkflowCompleted now) + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt + Right collected <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce + (addUTCTime 1 now) + WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 2} + Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId + parentGone `shouldBe` Nothing + Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId + childGone `shouldBe` Nothing + Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1" + childRows `shouldBe` 0 + + -- One failing deletion used to take the whole batch with it, and the + -- summary claimed everything eligible had been deleted regardless. The + -- sabotage is a workflow id long enough that its derived journal stream + -- name exceeds kiroku's 512-byte limit, so `hardDeleteStream` throws + -- `StreamNameTooLong` every time — no timing, no concurrency. + it "isolates a failing deletion, reports it honestly, and re-scans it" $ \storeHandle -> do + counter <- newIORef (0 :: Int) + let healthyName = WorkflowName "gc-isolated" + healthyId = WorkflowId "gi-1" + sabotagedId = Text.replicate 600 "x" + policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + Right (Completed _) <- + Store.runStoreIO storeHandle $ + runWorkflow healthyName healthyId (demoWorkflow counter) + -- Written directly: a workflow with this id could never journal anything, + -- because the same limit rejects its appends. GC eligibility reads only + -- the instance row, which is exactly the surface under test. + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (sabotagedId, "gc-sabotaged") insertTerminalGcInstanceStmt + now <- getCurrentTime + Right summary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce (addUTCTime 1 now) policy + summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 1} + -- The healthy workflow was collected despite the other one failing. + Right healthyGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance healthyName healthyId + healthyGone `shouldBe` Nothing + -- The sabotaged one kept its instance row, so it stays eligible: a + -- partially collected workflow converges instead of leaking. + Right nextSummary <- + Store.runStoreIO storeHandle $ + WorkflowGc.gcWorkflowsOnce (addUTCTime 2 now) policy + nextSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 0} + + it "keeps the gc loop alive across a pass it cannot finish" $ \storeHandle -> do + logged <- newIORef ([] :: [Text]) + let sabotagedId = Text.replicate 600 "x" + policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10} + -- A bare `forever` loop would report at most once and then die on the + -- error; per-pass isolation keeps it reporting every tick. + waitForTwoPasses = timeout 5_000_000 $ do + let go = do + seen <- readIORef logged + if length seen >= 2 + then pure () + else threadDelay 20_000 >> go + go + Right () <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.statement (sabotagedId, "gc-loop-sabotaged") insertTerminalGcInstanceStmt + worker <- + forkIO . void . Store.runStoreIO storeHandle $ + WorkflowGc.runWorkflowGcWorkerWith policy 20_000 (\msg -> modifyIORef' logged (msg :)) + reported <- waitForTwoPasses `finally` killThread worker + reported `shouldBe` Just () + messages <- readIORef logged + messages `shouldSatisfy` all ("stay eligible" `Text.isInfixOf`) + +-- | One resume pass over four candidates that exercise every outcome a pass +-- can report: one that completes, one that suspends, one whose name is absent +-- from the registry, and one that crashes into terminal failure at a ceiling of +-- one attempt. Parameterised by @maxConcurrentAdvances@ so the sequential and +-- concurrent runs are literally the same scenario. +runMixedResumePass :: Store.KirokuStore -> Int -> IO ResumeSummary +runMixedResumePass storeHandle concurrency = do + healthyCounter <- newIORef (0 :: Int) + let healthyName = WorkflowName "mixed-healthy" + suspendedName = WorkflowName "mixed-suspended" + poisonName = WorkflowName "mixed-poison" + orphanName = WorkflowName "mixed-orphan" + opts = + defaultWorkflowResumeOptions + & #maxAttempts + .~ 1 + & #maxConcurrentAdvances + .~ concurrency + & #logEvent + .~ const (pure ()) + registry = + Map.fromList + [ (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)), + (suspendedName, WorkflowDef (\_ -> neverArmingWorkflow)), + (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int))) + ] + now <- getCurrentTime + for_ [healthyName, suspendedName, poisonName, orphanName] $ \name -> + Store.runStoreIO + storeHandle + (appendJournalEntry name (WorkflowId "mixed-1") (StepRecorded "seed" (toJSON True) now)) + `shouldReturn` Right () + Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry + readIORef healthyCounter `shouldReturn` 3 + pure summary + +expectedMixedResumeSummary :: ResumeSummary +expectedMixedResumeSummary = + emptyResumeSummary + { discovered = 4, + advanced = 2, + resumed = 3, + completed = 1, + stillSuspended = 1, + unknownName = 1, + failed = 1, + unregisteredNames = Set.singleton "mixed-orphan" + } + +-- | Do two recorded execution windows intersect? Used to tell a concurrent +-- resume pass from a sequential one without measuring throughput. +windowsOverlap :: [(Text, UTCTime, UTCTime)] -> Bool +windowsOverlap = \case + [(_, startA, endA), (_, startB, endB)] -> startA < endB && startB < endA + _ -> False + +-- | Increment a shared counter and return its new value (the step's side +-- effect, so replay can be proven by watching the counter). +incrementAndRead :: IORef Int -> IO Int +incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1)) + +forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) () +forceWorkflowLeaseStmt = + preparable + """ + UPDATE keiro.keiro_workflows + SET leased_by = $3, + lease_expires_at = $4, + updated_at = now() + WHERE workflow_id = $1 + AND workflow_name = $2 + """ + ( contrazip4 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +-- | Six numbered steps, each returning its index after bumping a shared +-- counter. The counter lets a re-hydration prove the steps short-circuit +-- (it stays at 6 when every step is replayed from the journal/snapshot). +countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int] +countingSixSteps counter = + mapM + (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i)) + [1 .. 6] + +newtype Approx = Approx Double + deriving stock (Eq, Show) + +instance ToJSON Approx where + toJSON (Approx d) = toJSON (round d :: Int) + +instance FromJSON Approx where + parseJSON value = do + n <- Aeson.parseJSON value + pure (Approx (fromIntegral (n :: Int))) + +data RejectingRoundTrip = RejectingRoundTrip + deriving stock (Eq, Show) + +instance ToJSON RejectingRoundTrip where + toJSON RejectingRoundTrip = Aeson.String "not-an-object" + +instance FromJSON RejectingRoundTrip where + parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip + +-- | A distinguished exception used to simulate a process crash mid-workflow +-- (after a step has committed its journal append but before completion). +data SimulatedCrash = SimulatedCrash + deriving stock (Show) + +instance Exception SimulatedCrash + +-- | A three-step workflow; each step bumps a shared counter so a resume can +-- prove steps short-circuit (the counter only advances for steps that run). +threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +threeStep counter = do + a <- step (StepName "s1") (liftIO (incrementAndRead counter)) + b <- step (StepName "s2") (liftIO (incrementAndRead counter)) + c <- step (StepName "s3") (liftIO (incrementAndRead counter)) + pure (a, b, c) + +threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int) +threeStepThenSignal counter done = do + result <- threeStep counter + liftIO (putMVar done ()) + pure result + +-- | Runs step @"s1"@ (which commits its own journal append) then crashes, so +-- the journal is left with one StepRecorded and no WorkflowCompleted. +crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int) +crashAfterStep1 counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + _ <- liftIO (throwIO SimulatedCrash) + pure (0, 0, 0) + +-- | A workflow with one durable side effect before a switchable failure and +-- one durable side effect after it. Resurrection tests use the counter to prove +-- the recorded prefix never executes again. +recoverableWorkflow :: + (Workflow :> es, IOE :> es) => + IORef Bool -> + IORef Int -> + Eff es Int +recoverableWorkflow shouldCrash counter = do + _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter)) + crashing <- liftIO (readIORef shouldCrash) + when crashing (liftIO (throwIO SimulatedCrash)) + step (StepName "durable-tail") (liftIO (incrementAndRead counter)) + +-- | Awaits an external step, then runs a step that bumps the counter. Used to +-- prove the resume worker drives a suspended workflow to completion once its +-- awaited step is journaled. +awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +awaitingThenStep counter = do + decision <- awaitStep (StepName "awk:approval") (pure ()) + _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!")) + pure (decision <> "-done") + +-- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@ +-- unit-valued work steps to a running total, rotating its journal every +-- @rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair +-- @(runningTotal, stepsDoneGlobally)@ so each generation knows the global +-- progress; @genDone@ counts steps within the /current/ generation to bound it. +-- Each work step bumps @counter@ exactly once (proving rotation neither drops +-- nor double-counts) and returns 1, so the final total equals @total@. +-- +-- Step names are the global step index (@w0@, @w1@, …), so they are unique +-- within each generation's journal and replay-stable. Note the regression +-- direction: on a tree where 'continueAsNew' did not rotate, this body would put +-- all @total@ steps on generation 0's single journal and the per-generation +-- @<= K@ bound below would fail for @total > K@. +rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int +rollingTotal counter rotateEvery total = do + (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int) + go acc0 done0 0 + where + go acc done genDone + | done >= total = pure acc -- all global work done: this generation completes + | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward + | otherwise = do + n <- + step + (StepName ("w" <> Text.pack (show done))) + (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int))) + go (acc + n) (done + 1) (genDone + 1) + +-- The patch id under test (EP-49). +fraudPatchId :: PatchId +fraudPatchId = PatchId "fraud-check-v2" + +-- | The workflow BEFORE the patch shipped: reserve, then await an external step +-- (so an instance can be left in flight, mid-journal, with one ordinary step +-- recorded and no completion). Used to create the in-flight instance. +prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +prePatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight + pure "old-done" + +-- | The workflow AFTER the patch shipped: the same first step, then a +-- patch-gated cross-cutting branch. The in-flight instance (which already +-- journaled reserve-inventory under the pre-patch code) must observe False and +-- take the OLD branch; a fresh instance must observe True and take the NEW branch. +postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text +postPatchAfterSuspendWorkflow counter = do + _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ()) + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +prePatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + pure "old-done" + +postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text +postPatchWakeOnlyWorkflow = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text +rotatingPatchWorkflow = do + seed <- restoreSeed (0 :: Int) + if seed < 1 + then continueAsNew (seed + 1) + else do + useNew <- patch fraudPatchId + if useNew + then step (StepName "new-charge") (pure "new-branch") + else step (StepName "old-charge") (pure "old-branch") + +-- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then +-- runs a step that fills @done@ — so a test can observe the exact moment the +-- workflow resumes to completion. Awaiting first means the journal is empty until +-- the external gate append, which is what makes the instance discoverable by the +-- resume worker (the gate's StepRecorded is the first index row). +gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text +gateThenSignal done = do + (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) + _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ()) + pure "resumed" + +-- | A two-step workflow whose steps each bump a shared counter. +-- | Two steps whose names collided under the codepoint-truncating id +-- derivation: U+0101 and U+0001 both hashed as the single byte @0x01@, so the +-- second step's journal append was rejected as a duplicate event id. +collidingStepWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) +collidingStepWorkflow counter = do + a <- step (StepName "\x0101") (liftIO (incrementAndRead counter)) + b <- step (StepName "\SOH") (liftIO (incrementAndRead counter)) + pure (a, b) + +demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int) +demoWorkflow counter = do + a <- step (StepName "first") (liftIO (incrementAndRead counter)) + b <- step (StepName "second") (liftIO (incrementAndRead counter)) + pure (a, b) + +-- | A workflow that immediately awaits a step nothing ever arms — used to +-- exercise the suspend path and external completion. +neverArmingWorkflow :: (Workflow :> es) => Eff es Int +neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ()) + +-- | The awakeable validation workflow: allocate a durable promise, suspend on +-- it, and (once signalled) append "!" to the payload through a recorded step. +approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text +approvalFlowWithId ref = do + (aid, await) <- awakeableNamed (StepName "approval") + liftIO (writeIORef ref (Just aid)) + v <- await + step (StepName "use") (pure (v <> "!")) + +unicodeApprovalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text +unicodeApprovalFlowWithId ref = do + (aid, await) <- awakeableNamed (StepName "\x627F\x8A8D") + liftIO (writeIORef ref (Just aid)) + v <- await + step (StepName "use") (pure (v <> "!")) + +publishAwakeableBeforeAwait :: + forall es. + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es () +publishAwakeableBeforeAwait ref = do + (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") + _ <- + step (StepName "publish") $ do + liftIO (writeIORef ref (Just aid)) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +awaitPublishedAwakeable :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es Text +awaitPublishedAwakeable ref = do + (aid, await) <- awakeableNamed (StepName "gate") + _ <- + step (StepName "publish") $ do + liftIO (writeIORef ref (Just aid)) + await + +snapshotUnsignalledAwakeable :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es Text +snapshotUnsignalledAwakeable ref = do + (aid, await) <- awakeableNamed (StepName "gate") + liftIO (writeIORef ref (Just aid)) + await + +snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text +snapshotShadowedAwakeable = do + (aid, await) <- awakeableNamed (StepName "gate") + _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) + await + +snapshotStaleAwakeablePhaseOne :: + forall es. + (Workflow :> es, Store :> es, IOE :> es) => + IORef (Maybe AwakeableId) -> + Eff es () +snapshotStaleAwakeablePhaseOne ref = do + (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate") + liftIO (writeIORef ref (Just aid)) + _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text))) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text +snapshotStaleAwakeablePhaseTwo = do + (_aid, await) <- awakeableNamed (StepName "gate") + _ <- step (StepName "mid") (pure ()) + await + +snapshotStaleChildPhaseOne :: + (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) => + WorkflowId -> + Eff es () +snapshotStaleChildPhaseOne childWid = do + _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow + _ <- + step (StepName "drive") $ + void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow) + (_ :: ()) <- awaitStep (StepName "hold") (pure ()) + pure () + +snapshotStaleChildPhaseTwo :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> + Eff es Text +snapshotStaleChildPhaseTwo childWid = do + h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow + _ <- step (StepName "drive") (pure ()) + awaitChild h + +readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId +readRequiredAwakeableId ref = + readIORef ref >>= \case + Just aid -> pure aid + Nothing -> fail "workflow did not allocate an awakeable id" + +uuidLiteral :: String -> UUID +uuidLiteral raw = + case fromString raw of + Just uuid -> uuid + Nothing -> error ("invalid UUID literal in test: " <> raw) + +-- | A two-step workflow with a durable sleep between the steps. The sleep's +-- name and delay are parameters so one helper drives both the zero-delta and +-- the real-time tests. +sleepDemoNamed :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int) +sleepDemoNamed counter sName delta = do + a <- step (StepName "a") (liftIO (incrementAndRead counter)) + sleepNamed sName delta + b <- step (StepName "b") (liftIO (incrementAndRead counter)) + pure (a, b) + +-- | Two sleeps on one generation with a step between them: the first is due +-- immediately, the second far in the future. Firing the first and resuming +-- moves the live wake hint onto the second sleep, which is the state a stale +-- re-fire of the first timer must not disturb. +twoSleepWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> Eff es Int +twoSleepWorkflow counter = do + sleepNamed (StepName "first") 0 + n <- step (StepName "mid") (liftIO (incrementAndRead counter)) + sleepNamed (StepName "second") 3600 + pure n + +rollingSleepWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef Int -> Eff es Int +rollingSleepWorkflow counter = do + seed <- restoreSeed (0 :: Int) + _ <- step (StepName "work") (liftIO (incrementAndRead counter)) + if seed < 2 + then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1) + else pure seed + +rollingAwakeableWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + IORef [AwakeableId] -> Eff es Text +rollingAwakeableWorkflow idsRef = do + seed <- restoreSeed (0 :: Int) + (aid, await) <- awakeableNamed (StepName "gate") + liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid])) + value <- await + if seed < 1 + then continueAsNew (seed + 1) + else step (StepName "use") (pure value) + +rotatingParentWorkflow :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> Eff es Text +rotatingParentWorkflow childWid = do + seed <- restoreSeed (0 :: Int) + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + if seed < 1 + then continueAsNew (seed + 1) + else pure result + +failedChildBeforeRotation :: + (Workflow :> es, Store :> es) => + WorkflowId -> + Eff es Text +failedChildBeforeRotation childWid = do + _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow + awaitStep (StepName "rotation-gate") (pure ()) + +rotatePastFailedChild :: + (Workflow :> es, Store :> es) => + WorkflowId -> + Eff es Text +rotatePastFailedChild childWid = do + _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow + continueAsNew () + +catchFailedChildAfterRotation :: + (Workflow :> es, Store :> es, IOE :> es) => + WorkflowId -> + Eff es Text +catchFailedChildAfterRotation childWid = do + child <- spawnChild (WorkflowName "ship") childWid shipWorkflow + EffException.catch + (awaitChild child) + (\(WorkflowChildFailed _ _ reason) -> pure reason) + +-- | A workflow that records one step, then suspends on an await — so it has a +-- step row but no completion marker (the unfinished-discovery case). +stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int +stepThenAwaitWorkflow counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + awaitStep (StepName "awk:wait") (pure ()) + +-- | Two sequential gates. Journaling the first makes the workflow discoverable +-- again; the resulting re-invocation replays past it and parks on the second, +-- so the run is re-invoked and still suspends. +twoGateWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int +twoGateWorkflow counter = do + _ <- step (StepName "s1") (liftIO (incrementAndRead counter)) + (_ :: ()) <- awaitStep (StepName "awk:first") (pure ()) + awaitStep (StepName "awk:second") (pure ()) + +-- | A two-step child workflow used in the child-workflow tests. +shipWorkflow :: (Workflow :> es) => Eff es Text +shipWorkflow = do + a <- step (StepName "pack") (pure ("packed" :: Text)) + b <- step (StepName "label") (pure (a <> "+labelled")) + pure b + +-- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and +-- then records a @notify@ step. Parametrised by child id so each test isolates +-- its own child journal. +parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text +parentWorkflow childWid = do + h <- spawnChild (WorkflowName "ship") childWid shipWorkflow + result <- awaitChild h + _ <- step (StepName "notify") (pure ("done:" <> result)) + pure ("done:" <> result) + +jsonObjectChildWorkflow :: Eff es Aeson.Value +jsonObjectChildWorkflow = + pure (object ["cancelled" Aeson..= True]) + +jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value +jsonObjectParentWorkflow childWid = do + h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow + result <- awaitChild h + _ <- step (StepName "json-notify") (pure ()) + pure result + +-- | The failure counterpart of 'selfCancellingWorkflow': step one's action +-- writes this workflow's own terminal failure marker, standing in for the +-- resume worker marking it failed while another runner is mid-run. +selfFailingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int +selfFailingWorkflow name wid counter = do + _ <- + step (StepName "one") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (WorkflowFailed "ceiling reached" now) + liftIO (incrementAndRead counter) + step (StepName "two") (liftIO (incrementAndRead counter)) + +selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int +selfCancellingWorkflow name wid counter = do + _ <- step (StepName "one") (liftIO (incrementAndRead counter)) + _ <- + step (StepName "two") $ do + now <- liftIO getCurrentTime + appendJournalEntry name wid (WorkflowCancelled now) + liftIO (incrementAndRead counter) + step (StepName "three") (liftIO (incrementAndRead counter)) + +nominalDays :: Int -> NominalDiffTime +nominalDays n = fromIntegral n * 86400 + +attrKeyText :: AttributeKey Text -> Text +attrKeyText = unkey + +attrKeyTextInt64 :: AttributeKey Int64 -> Text +attrKeyTextInt64 = unkey + +textAttr :: Attributes -> Text -> Maybe Text +textAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (TextAttribute t)) -> Just t + _ -> Nothing + +intAttr :: Attributes -> Text -> Maybe Int64 +intAttr attrs name = case lookupAttribute attrs name of + Just (AttributeValue (IntAttribute n)) -> Just n + _ -> Nothing + +-- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the +-- mutable span fields (name, attributes, status) live behind the +-- @spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan', +-- so the tests read that reference once after the span ends and assert on +-- this flat record. +data CapturedSpan = CapturedSpan + { csName :: Text, + csKind :: SpanKind, + csAttributes :: Attributes, + csStatus :: SpanStatus, + csContext :: SpanContext, + csParent :: Maybe Span + } + +captureSpan :: ImmutableSpan -> IO CapturedSpan +captureSpan sp = do + hot <- readIORef (spanHot sp) + pure + CapturedSpan + { csName = hotName hot, + csKind = spanKind sp, + csAttributes = hotAttributes hot, + csStatus = hotStatus hot, + csContext = spanContext sp, + csParent = spanParent sp + } + +-- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an +-- incrementing offset. The publisher pushes records here; the consumer +-- drains the MVar. There is no real broker — the goal of the fixture is +-- to validate that the keiro envelope and outbox/inbox semantics +-- compose correctly across two isolated PostgreSQL contexts. +newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord])) + +newKafkaTopic :: IO KafkaTopic +newKafkaTopic = KafkaTopic <$> newMVar (0, []) + +kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m () +kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do + let record = OutboxKafka.outboxRowToKafkaRecord row + headersText = + [ (TE.decodeUtf8 name, TE.decodeUtf8 value) + | (name, value) <- record ^. #headers + ] + now <- getCurrentTime + modifyMVar ref $ \(nextOffset, acc) -> + let inbound = + InboxKafka.KafkaInboundRecord + { topic = record ^. #topic, + partition = 0, + offset = nextOffset, + key = fmap TE.decodeUtf8 (record ^. #key), + payload = record ^. #payload, + headers = headersText, + receivedAt = now + } + in pure ((nextOffset + 1, inbound : acc), ()) + +kafkaTopicPublish :: + forall es. + (IOE :> es) => + KafkaTopic -> + OutboxRow -> + Eff es PublishOutcome +kafkaTopicPublish topic row = do + kafkaTopicAccept topic row + pure PublishSucceeded + +perRow :: + (OutboxRow -> Eff es PublishOutcome) -> + [OutboxRow] -> + Eff es [(OutboxId, PublishOutcome)] +perRow publish rows = + traverse publishOne rows + where + publishOne row = do + outcome <- publish row + pure (row ^. #outboxId, outcome) + +drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord] +drainKafkaTopic (KafkaTopic ref) = do + (_, acc) <- readMVar ref + pure (reverse acc) + +redeliverWithDifferentOffset :: + InboxKafka.KafkaInboundRecord -> + InboxKafka.KafkaInboundRecord +redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000 + +data ConsumeResult a + = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError + | ConsumePolicyUnsatisfied !InboxError + | ConsumeApplied !(InboxResult a) + deriving stock (Eq, Show) + +-- | A worker-shaped consumer: decode the Kafka record into an +-- IntegrationEvent and run it through the inbox. +consumeAndApply :: + forall es. + (IOE :> es, Store :> es) => + InboxKafka.KafkaInboundRecord -> + (IntegrationEvent -> Tx.Transaction ()) -> + Eff es (ConsumeResult ()) +consumeAndApply record handler = + case InboxKafka.integrationEventFromKafka record of + Left err -> pure (ConsumeDecodeFailed err) + Right (event, kafkaRef) -> do + result <- + runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler + case result of + Left err -> pure (ConsumePolicyUnsatisfied err) + Right applied -> pure (ConsumeApplied applied) + +billingReactionHandler :: IntegrationEvent -> Tx.Transaction () +billingReactionHandler event = case decodeJsonIntegrationEvent event of + Left _ -> Tx.condemn + Right (OrderSubmittedPayload orderId quantity) -> + Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt + +loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction () +loggingReactionHandler _ event = do + -- The cross-context test only needs the (eventType, key) pair, not + -- the decoded payload. + let key = fromMaybe "" (event ^. #key) + Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt + +insertReceivedOrderStmt :: Statement (Text, Int64) () +insertReceivedOrderStmt = + preparable + """ + INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2) + ON CONFLICT (order_id) DO NOTHING + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int8)) + ) + D.noResult + +billingReceivedOrdersCountStmt :: Statement () Int +billingReceivedOrdersCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM billing_received_orders" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +appendBillingEventLogStmt :: Statement (Text, Text, Text) () +appendBillingEventLogStmt = + preparable + "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)" + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + D.noResult + +billingEventLogStmt :: Statement () [(Text, Text)] +billingEventLogStmt = + preparable + "SELECT event_type, order_id FROM billing_event_log ORDER BY seq" + E.noParams + ( D.rowList + ( (,) + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + ) + ) + +orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent +orderSubmittedEnvelope orderId quantity messageId = + encodeJsonIntegrationEvent + ( sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderSubmitted" + & #key + .~ Just orderId + ) + (OrderSubmittedPayload orderId quantity) + +orderCancelledEnvelope :: Text -> Text -> IntegrationEvent +orderCancelledEnvelope orderId messageId = + sampleIntegrationEnvelope + & #messageId + .~ messageId + & #eventType + .~ "OrderCancelled" + & #key + .~ Just orderId + & #payloadBytes + .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}") + & #contentType + .~ ApplicationJson + +prepareDelegatedDeniedInboxRole :: Store.KirokuStore -> IO () +prepareDelegatedDeniedInboxRole storeHandle = do + prepared <- + Store.runStoreIO storeHandle $ + Store.runTransaction $ + Tx.sql $ + ByteString.intercalate + "\n" + [ "CREATE TABLE IF NOT EXISTS kiroku.inbox_test_counter (message_id TEXT PRIMARY KEY);", + "DO $role$ BEGIN", + " IF NOT EXISTS (SELECT 1 FROM pg_roles WHERE rolname = 'delegated_inbox_denied') THEN", + " CREATE ROLE delegated_inbox_denied LOGIN;", + " END IF;", + "END $role$;", + "GRANT USAGE ON SCHEMA kiroku, keiro, public TO delegated_inbox_denied;", + "GRANT SELECT, INSERT, UPDATE, DELETE ON ALL TABLES IN SCHEMA kiroku, public TO delegated_inbox_denied;", + "GRANT USAGE, SELECT, UPDATE ON ALL SEQUENCES IN SCHEMA kiroku, public TO delegated_inbox_denied;", + "GRANT EXECUTE ON ALL FUNCTIONS IN SCHEMA kiroku, public TO delegated_inbox_denied;", + "REVOKE ALL PRIVILEGES ON TABLE keiro.keiro_inbox FROM delegated_inbox_denied;" + ] + either (fail . show) pure prepared + +inboxTestCounterInsertStmt :: Statement Text () +inboxTestCounterInsertStmt = + preparable + "INSERT INTO inbox_test_counter (message_id) VALUES ($1)" + (E.param (E.nonNullable E.text)) + D.noResult + +inboxTestCounterCountStmt :: Statement () Int +inboxTestCounterCountStmt = + preparable + "SELECT COUNT(*)::bigint FROM inbox_test_counter" + E.noParams + (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8))) + +sampleProducer :: IntegrationProducer () +sampleProducer = + IntegrationProducer + { name = "ordering-integration-producer", + source = "ordering", + messageIdPrefix = "msg", + mapEvent = \_recorded () -> Just sampleDraft + } + +sampleDraft :: IntegrationEventDraft +sampleDraft = + IntegrationEventDraft + { destination = "billing.orders.v1", + key = Just "order-123", + eventType = "OrderSubmitted", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = Nothing, + sourceEventId = Nothing, + sourceGlobalPosition = Nothing, + payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", + occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + causationId = Nothing, + correlationId = Nothing, + traceContext = Nothing, + attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)]) + } + +sampleOutboxRow :: IntegrationEvent -> OutboxRow +sampleOutboxRow event = + OutboxRow + { outboxId = OutboxId outboxUuid1, + event, + status = OutboxPending, + attemptCount = 0, + nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + lastError = Nothing, + publishedAt = Nothing, + rejectedAt = Nothing, + rejection = Nothing, + createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0) + } + +backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxUpdatedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt + +backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxUpdatedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es () +backdateOutboxPublishedAt oid timestamp = + Store.runTransaction $ + Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt + +backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) () +backdateOutboxPublishedAtStmt = + preparable + "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1" + ( contrazip2 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.timestamptz)) + ) + D.noResult + +outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID +outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 1" +outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 2" +outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 3" +outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of + Just uuid -> uuid + Nothing -> error "invalid outbox uuid 4" + +outboxIdFromOrdinal :: Word64 -> OutboxId +outboxIdFromOrdinal n = + OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n)) + +uniqueIds :: (Eq a) => [a] -> [a] +uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) [] + +data OrderSubmittedPayload = OrderSubmittedPayload + { orderId :: !Text, + quantity :: !Int + } + deriving stock (Generic, Eq, Show) + +instance ToJSON OrderSubmittedPayload where + toJSON = genericToJSON (aesonPrefix camelCase) + toEncoding = genericToEncoding (aesonPrefix camelCase) + +instance FromJSON OrderSubmittedPayload where + parseJSON = genericParseJSON (aesonPrefix camelCase) + +sampleIntegrationEnvelope :: IntegrationEvent +sampleIntegrationEnvelope = + IntegrationEvent + { messageId = "018f0f18-17aa-7000-8000-0000000000aa", + source = "ordering", + destination = "billing.orders.v1", + key = Just "order-123", + eventType = "OrderSubmitted", + schemaVersion = 1, + contentType = ApplicationJson, + schemaReference = + Just + SchemaReference + { registry = Just "https://schemas.example/registry", + subject = Just "billing.orders.v1.OrderSubmitted", + version = Just 1, + schemaId = Just 42, + fingerprint = Just "sha256:abc123" + }, + sourceEventId = Just (EventId integrationSourceEventUuid), + sourceGlobalPosition = Just (GlobalPosition 42), + payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}", + occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0), + causationId = Just (EventId integrationCausationUuid), + correlationId = Just (EventId integrationCorrelationUuid), + traceContext = + Just + TraceContext + { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01", + tracestate = Just "rojo=00f067aa0ba902b7" + }, + attributes = Nothing + } + +integrationSourceEventUuid :: UUID +integrationSourceEventUuid = + case fromString "018f0f18-17aa-7000-8000-000000000003" of + Just uuid -> uuid + Nothing -> error "invalid integration source event UUID" + +integrationCausationUuid :: UUID +integrationCausationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000004" of + Just uuid -> uuid + Nothing -> error "invalid integration causation UUID" + +integrationCorrelationUuid :: UUID +integrationCorrelationUuid = + case fromString "018f0f18-17aa-7000-8000-000000000005" of + Just uuid -> uuid + Nothing -> error "invalid integration correlation UUID" + +data OrderStream + +data OrderEvent + = OrderPlaced !Text !Int + deriving stock (Generic, Eq, Show) + +data OrderState + = Idle + deriving stock (Generic, Eq, Show) + +data OrderCommand + = PlaceOrder + deriving stock (Generic, Eq, Show) + +orderCodec :: Codec OrderEvent +orderCodec = + Codec + { eventTypes = EventType "OrderPlaced" :| [], + eventType = \case + OrderPlaced {} -> EventType "OrderPlaced", + schemaVersion = 2, + encode = \case + OrderPlaced orderId quantity -> + object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity], + decode = parseOrderPlaced, + upcasters = [(1, const upcastOrderPlacedV1)] + } + +gappyCodec :: Codec OrderEvent +gappyCodec = + Codec + { eventTypes = orderCodec ^. #eventTypes, + eventType = orderCodec ^. #eventType, + schemaVersion = 4, + encode = orderCodec ^. #encode, + decode = orderCodec ^. #decode, + upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)] + } + +parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent +parseOrderPlaced _ value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlaced" $ \objectValue -> + OrderPlaced + <$> objectValue .: "orderId" + <*> objectValue .: "quantity" + +upcastOrderPlacedV1 :: Value -> Either Text Value +upcastOrderPlacedV1 value = + case parseEither parser value of + Right migrated -> Right migrated + Left message -> Left (fromStringLiteral message) + where + parser = withObject "OrderPlacedV1" $ \objectValue -> do + orderId <- objectValue .: "orderId" + quantity <- objectValue .: "qty" + pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)]) + +metadataForOrDie :: Int -> Maybe Value -> Value +metadataForOrDie version existing = + either (error . show) id (metadataFor version existing) + +emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent +emptyTransducer = + SymTransducer + { edgesOut = \_ -> [], + initial = Idle, + initialRegs = RNil, + isFinal = \_ -> True + } + +type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent + +type DelegatedOneShotEventStream = EventStream (HsPred '[] CounterCommand) '[] DelegatedOneShotState CounterCommand CounterEvent + +type ValidatedDelegatedOneShotEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DelegatedOneShotState CounterCommand CounterEvent + +type SnapshotCounterRegs = '[ '("lastAmount", Int)] + +type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)] + +type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent + +type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent + +type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent + +data CounterCommand + = Add !Int + deriving stock (Generic, Eq, Show) + +data SkipCommand + = SAdd !Int + | SSkip + deriving stock (Generic, Eq, Show) + +data CounterEvent + = CounterAdded !Int + | CounterAudited !Int + deriving stock (Generic, Eq, Show) + +data CounterState + = Counting + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape CounterState + +data DelegatedOneShotState + = DelegatedReady + | DelegatedDone + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +data CounterStateV2 + = CountingV2 + | PausedV2 + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape CounterStateV2 + +data DrainState + = Draining + | Drained + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +data PartialSnapshotState + = SnapshotEncodable + | SnapshotEncodeBomb + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +instance CanonicalStateShape PartialSnapshotState + +instance ToJSON PartialSnapshotState where + toJSON SnapshotEncodable = Aeson.String "encodable" + toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded" + +instance FromJSON PartialSnapshotState where + parseJSON = Aeson.withText "PartialSnapshotState" $ \case + "encodable" -> pure SnapshotEncodable + "bomb" -> pure SnapshotEncodeBomb + other -> fail ("unknown partial snapshot state: " <> Text.unpack other) + +counterEventStreamDef :: CounterEventStream +counterEventStreamDef = + EventStream + { transducer = counterTransducer, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +counterEventStream :: ValidatedCounterEventStream +counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef + +delegatedOneShotEventStream :: ValidatedDelegatedOneShotEventStream +delegatedOneShotEventStream = + mkEventStreamOrThrow + "delegated-one-shot" + EventStream + { transducer = + SymTransducer + { edgesOut = \case + DelegatedReady -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = DelegatedDone, + mode = Keiki.Live + } + ] + DelegatedDone -> [], + initial = DelegatedReady, + initialRegs = RNil, + isFinal = (== DelegatedDone) + }, + initialState = DelegatedReady, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +auditedCounterEventStream :: ValidatedCounterEventStream +auditedCounterEventStream = + mkEventStreamOrThrow + "counter-audited-only" + (counterEventStreamDef & #transducer .~ auditedCounterTransducer) + +auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +auditedCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +noOpCounterEventStreamDef :: CounterEventStream +noOpCounterEventStreamDef = + counterEventStreamDef & #transducer .~ noOpCounterTransducer + +noOpCounterEventStream :: ValidatedCounterEventStream +noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef + +counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +counterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +noOpCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +multiCounterEventStreamDef :: CounterEventStream +multiCounterEventStreamDef = + counterEventStreamDef & #transducer .~ multiCounterTransducer + +multiCounterEventStream :: ValidatedCounterEventStream +multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef + +multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +multiCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +-- | Both guards match at runtime but remain outside keiki's conservative pure +-- overlap fragment. Distinct head event constructors keep inversion unambiguous, +-- so this is a validated stream that exercises the runtime step witness. +ambiguousCounterEventStreamDef :: CounterEventStream +ambiguousCounterEventStreamDef = + counterEventStreamDef & #transducer .~ ambiguousCounterTransducer + +ambiguousCounterEventStream :: ValidatedCounterEventStream +ambiguousCounterEventStream = + mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef + +ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +ambiguousCounterTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = ambiguousGuard, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = ambiguousGuard, + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ] + } + where + ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot) + +snapshotCounterEventStreamDef :: SnapshotCounterEventStream +snapshotCounterEventStreamDef = + EventStream + { transducer = snapshotCounterTransducer, + initialState = Counting, + initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 2, + stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1) + } + +partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent +partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef + +partialSnapshotEventStreamDef :: PartialSnapshotEventStream +partialSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \_ -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = SnapshotEncodeBomb, + mode = Keiki.Live + } + ], + initial = SnapshotEncodable, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + }, + initialState = SnapshotEncodable, + initialRegisters = RCons (Proxy @"lastAmount") 0 RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 1, + stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1) + } + +uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +uninitializedSnapshotEventStreamDef = + initializedSnapshotEventStreamDef + & #initialRegisters + .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)]) + +initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream +initializedSnapshotEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \case Counting -> [], + initial = Counting, + initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), + isFinal = \_ -> False + }, + initialState = Counting, + initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil), + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Every 2, + stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1) + } + +snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef + +snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +snapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +foldV1SnapshotCounterEventStream = + mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef + +foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream +foldV1SnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef + { transducer = foldV1SnapshotCounterTransducer, + stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + ) + } + +foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +foldV2SnapshotCounterEventStream = + mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef + +foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream +foldV2SnapshotCounterEventStreamDef = + foldV1SnapshotCounterEventStreamDef + { transducer = foldV2SnapshotCounterTransducer, + snapshotPolicy = Every 1, + stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v2") + 1 + ) + } + +foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream +foldV2WithoutFingerprintBumpEventStream = + mkEventStreamOrThrow + "snapshot-counter-fold-v2-without-fingerprint-bump" + foldV2WithoutFingerprintBumpEventStreamDef + +foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream +foldV2WithoutFingerprintBumpEventStreamDef = + foldV2SnapshotCounterEventStreamDef + { stateCodec = + Just + ( defaultStateCodecWithFold + @SnapshotCounterRegs + @CounterState + (FoldVersion "fold-v1") + 1 + ) + } + +foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldV1SnapshotCounterTransducer = + foldSnapshotCounterTransducer + (inpCtor addCtor #amount) + +foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldV2SnapshotCounterTransducer = + foldSnapshotCounterTransducer + (inpCtor addCtor #amount K..+ lit 1) + +foldSnapshotCounterTransducer :: + Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int -> + SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +foldSnapshotCounterTransducer nextLastAmount = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (inpCtor addCtor #amount K..< lit 100), + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + nextLastAmount, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = + PAnd + (matchInCtor addCtor) + ( PAnd + (inpCtor addCtor #amount K..>= lit 100) + ( inpCtor addCtor #amount + .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100) + ) + ), + update = UKeep, + output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +multiSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef + & #transducer + .~ multiSnapshotCounterTransducer + & #snapshotPolicy + .~ Every 1 + +multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef + +multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +multiSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = + [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +guardedSnapshotCounterEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer + +guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef + +guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +guardedSnapshotCounterTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = + PAnd + (matchInCtor addCtor) + (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int)), + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +-- | A deliberately replay-unsafe stream: its single edge is an ε-edge +-- (empty @output@) whose @update@ reads the command's @amount@. Because +-- the edge emits no event, that command field cannot be recovered on +-- replay, so keiki's hidden-input check flags it. Used to prove +-- 'validateEventStream' / 'mkEventStream' reject an unsafe stream. +brokenHiddenInputEventStream :: SnapshotCounterEventStream +brokenHiddenInputEventStream = + snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer + +brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +brokenHiddenInputTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (inpCtor addCtor #amount), + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RCons (Proxy @"lastAmount") 0 RNil, + isFinal = \_ -> False + } + +-- | A multi-event edge whose tail carries the command field omitted from its +-- head. The union of the outputs covers @amount@, but replay commits to an edge +-- by inverting only the head, so the stored chain cannot reconstruct @Add@. +headUnrecoverableEventStreamDef :: CounterEventStream +headUnrecoverableEventStreamDef = + counterEventStreamDef & #transducer .~ headUnrecoverableTransducer + +headUnrecoverableEventStream :: ValidatedCounterEventStream +headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef + +headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +headUnrecoverableTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = + [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil), + pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil) + ], + target = Counting, + mode = Keiki.Live + } + ] + } + +-- | Two edges share a head wire constructor, so one stored event can invert +-- through both. The double-negated guard is true at runtime but deliberately +-- outside keiki's pure overlap fragment, isolating the inversion warning from +-- the separate conservative determinism check. +inversionAmbiguousEventStreamDef :: CounterEventStream +inversionAmbiguousEventStreamDef = + counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer + +inversionAmbiguousEventStream :: ValidatedCounterEventStream +inversionAmbiguousEventStream = + case mkEventStreamWith + Keiki.defaultValidationOptions {Keiki.checkInversionAmbiguity = False} + "counter-inversion-ambiguous" + inversionAmbiguousEventStreamDef of + Right validated -> validated + Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings) + +inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +inversionAmbiguousTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ ambiguousEdge, + ambiguousEdge + ] + } + where + ambiguousEdge = + Edge + { guard = PAnd (matchInCtor addCtor) (PNot PBot), + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + +-- | This edge reads @Add.amount@ while guarded only by @PTop@. A different +-- command constructor would reach the partial projection and crash instead of +-- being rejected. +unguardedInputReadEventStreamDef :: CounterEventStream +unguardedInputReadEventStreamDef = + counterEventStreamDef & #transducer .~ unguardedInputReadTransducer + +unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent +unguardedInputReadTransducer = + counterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = PTop, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + } + ] + } + +-- | A silent self-loop that writes a register. With no emitted event the +-- write cannot be reconstructed from the durable log. +stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream +stateChangingEpsilonEventStreamDef = + snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer + +stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent +stateChangingEpsilonTransducer = + snapshotCounterTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor addCtor, + update = + USet + (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int) + (Keiki.lit 0), + output = [], + target = Counting, + mode = Keiki.Live + } + ] + } + +type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent + +silentMoveEventStreamDef :: SilentMoveEventStream +silentMoveEventStreamDef = + EventStream + { transducer = silentMoveTransducer, + initialState = Draining, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent +silentMoveTransducer = + SymTransducer + { edgesOut = \case + Draining -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [], + target = Drained, + mode = Keiki.Live + } + ] + Drained -> [], + initial = Draining, + initialRegs = RNil, + isFinal = (== Drained) + } + +isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool +isStateChangingEpsilon = \case + Keiki.StateChangingEpsilon {} -> True + _ -> False + +expectValidationWarning :: + (Bounded s, Enum s, Ord s, Show s) => + Text -> + Text -> + EventStream (HsPred rs ci) rs s ci co -> + Expectation +expectValidationWarning label prefix eventStream = + case mkEventStream label eventStream of + Left warnings -> do + map eswStreamLabel warnings `shouldSatisfy` all (== label) + map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix) + Right _ -> + expectationFailure + ( "expected mkEventStream to reject " + <> Text.unpack label + <> " with warning prefix " + <> Text.unpack prefix + ) + +type AddFields = '[ '("amount", Int)] + +type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent + +data SilentChoiceCommand + = RejectSilently + | NoOpSilently + | UnmatchedSilently + deriving stock (Generic, Eq, Show) + +data CoordinatorCommand + = CoordinatorAccept !Int + | CoordinatorReject !Text + | CoordinatorNoOp !Text + | CoordinatorUnmatched + deriving stock (Generic, Eq, Show) + +data DomainDispatchInput = DomainDispatchInput !Text ![CoordinatorCommand] + deriving stock (Generic, Eq, Show) + +type SilentChoiceEventStream = EventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent + +type ValidatedSilentChoiceEventStream = ValidatedEventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent + +type CoordinatorEventStream = EventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent + +type ValidatedCoordinatorEventStream = ValidatedEventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent + +type RetryDecisionEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent + +type ValidatedRetryDecisionEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent + +data FeasibilityGateCommand + = TryAccept !Int + | OpenGate + deriving stock (Generic, Eq, Show) + +data FeasibilityGateEvent + = GateOpened + | GateAccepted !Int + deriving stock (Generic, Eq, Show) + +data FeasibilityGateState + = GateClosed + | GateOpen + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +type FeasibilityGateEventStream = EventStream (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent + +type ValidatedFeasibilityGateEventStream = ValidatedEventStream (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent + +skipEventStream :: ValidatedSkipEventStream +skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef + +skipEventStreamDef :: SkipEventStream +skipEventStreamDef = + EventStream + { transducer = skipTransducer, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +silentChoiceEventStream :: ValidatedSilentChoiceEventStream +silentChoiceEventStream = mkEventStreamOrThrow "silent-choice-command" silentChoiceEventStreamDef + +silentChoiceEventStreamDef :: SilentChoiceEventStream +silentChoiceEventStreamDef = + EventStream + { transducer = silentChoiceTransducer, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +retryDecisionEventStream :: ValidatedRetryDecisionEventStream +retryDecisionEventStream = mkEventStreamOrThrow "retry-domain-decision" retryDecisionEventStreamDef + +retryDecisionEventStreamDef :: RetryDecisionEventStream +retryDecisionEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \case + Draining -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)], + target = Drained, + mode = Keiki.Live + } + ] + Drained -> + [ Edge + { guard = matchInCtor addCtor, + update = UKeep, + output = [], + target = Drained, + mode = Keiki.Live + } + ], + initial = Draining, + initialRegs = RNil, + isFinal = const False + }, + initialState = Draining, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +feasibilityGateEventStream :: ValidatedFeasibilityGateEventStream +feasibilityGateEventStream = mkEventStreamOrThrow "reaction-feasibility-gate" feasibilityGateEventStreamDef + +feasibilityGateEventStreamDef :: FeasibilityGateEventStream +feasibilityGateEventStreamDef = + EventStream + { transducer = feasibilityGateTransducer, + initialState = GateClosed, + initialRegisters = RNil, + eventCodec = feasibilityGateCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +feasibilityGateTransducer :: SymTransducer (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent +feasibilityGateTransducer = + SymTransducer + { edgesOut = \case + GateClosed -> + [ Edge + { guard = matchInCtor tryAcceptCtor, + update = UKeep, + output = [], + target = GateClosed, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor openGateCtor, + update = UKeep, + output = [pack openGateCtor gateOpenedCtor oNil], + target = GateOpen, + mode = Keiki.Live + } + ] + GateOpen -> + [ Edge + { guard = matchInCtor tryAcceptCtor, + update = UKeep, + output = [pack tryAcceptCtor gateAcceptedCtor (inpCtor tryAcceptCtor #amount *: oNil)], + target = GateOpen, + mode = Keiki.Live + } + ], + initial = GateClosed, + initialRegs = RNil, + isFinal = const False + } + +tryAcceptCtor :: InCtor FeasibilityGateCommand AddFields +tryAcceptCtor = + Keiki.unavailableInCtor + "TryAccept" + (\case TryAccept amount -> Just (RCons Proxy amount RNil); OpenGate -> Nothing) + (\case RCons _ amount RNil -> TryAccept amount) + +openGateCtor :: InCtor FeasibilityGateCommand '[] +openGateCtor = + Keiki.unavailableInCtor + "OpenGate" + (\case OpenGate -> Just RNil; TryAccept {} -> Nothing) + (\RNil -> OpenGate) + +gateOpenedCtor :: WireCtor FeasibilityGateEvent () +gateOpenedCtor = + Keiki.unavailableWireCtor + "GateOpened" + (\case GateOpened -> Just (); GateAccepted {} -> Nothing) + (const GateOpened) + +gateAcceptedCtor :: WireCtor FeasibilityGateEvent (Int, ()) +gateAcceptedCtor = + Keiki.unavailableWireCtor + "GateAccepted" + (\case GateAccepted amount -> Just (amount, ()); GateOpened -> Nothing) + (\case (amount, ()) -> GateAccepted amount) + +feasibilityGateCodec :: Codec FeasibilityGateEvent +feasibilityGateCodec = + Codec + { eventTypes = EventType "GateOpened" :| [EventType "GateAccepted"], + eventType = \case GateOpened -> EventType "GateOpened"; GateAccepted {} -> EventType "GateAccepted", + schemaVersion = 1, + encode = \case + GateOpened -> object [] + GateAccepted amount -> object ["amount" Aeson..= amount], + decode = \(EventType tag) value -> + case tag of + "GateOpened" -> Right GateOpened + "GateAccepted" -> + case parseEither (withObject "GateAccepted" (.: "amount")) value of + Right amount -> Right (GateAccepted amount) + Left message -> Left (fromStringLiteral message) + _ -> Left ("unknown feasibility gate event type: " <> tag), + upcasters = [] + } + +coordinatorEventStream :: ValidatedCoordinatorEventStream +coordinatorEventStream = mkEventStreamOrThrow "coordinator-domain" coordinatorEventStreamDef + +coordinatorEventStreamDef :: CoordinatorEventStream +coordinatorEventStreamDef = + EventStream + { transducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor coordinatorAcceptCtor, + update = UKeep, + output = [pack coordinatorAcceptCtor counterAddedCtor (inpCtor coordinatorAcceptCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor coordinatorRejectCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor coordinatorNoOpCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = const False + }, + initialState = Counting, + initialRegisters = RNil, + eventCodec = counterCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +type CoordinatorMessageFields = '[ '("message", Text)] + +coordinatorAcceptCtor :: InCtor CoordinatorCommand AddFields +coordinatorAcceptCtor = + Keiki.unavailableInCtor + "CoordinatorAccept" + (\case CoordinatorAccept amount -> Just (RCons Proxy amount RNil); _ -> Nothing) + (\case RCons _ amount RNil -> CoordinatorAccept amount) + +coordinatorRejectCtor :: InCtor CoordinatorCommand CoordinatorMessageFields +coordinatorRejectCtor = + Keiki.unavailableInCtor + "CoordinatorReject" + (\case CoordinatorReject message -> Just (RCons Proxy message RNil); _ -> Nothing) + (\case RCons _ message RNil -> CoordinatorReject message) + +coordinatorNoOpCtor :: InCtor CoordinatorCommand CoordinatorMessageFields +coordinatorNoOpCtor = + Keiki.unavailableInCtor + "CoordinatorNoOp" + (\case CoordinatorNoOp message -> Just (RCons Proxy message RNil); _ -> Nothing) + (\case RCons _ message RNil -> CoordinatorNoOp message) + +silentChoiceTransducer :: SymTransducer (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent +silentChoiceTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor rejectSilentlyCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor noOpSilentlyCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +rejectSilentlyCtor :: InCtor SilentChoiceCommand '[] +rejectSilentlyCtor = + Keiki.unavailableInCtor + "RejectSilently" + (\case RejectSilently -> Just RNil; _ -> Nothing) + (\RNil -> RejectSilently) + +noOpSilentlyCtor :: InCtor SilentChoiceCommand '[] +noOpSilentlyCtor = + Keiki.unavailableInCtor + "NoOpSilently" + (\case NoOpSilently -> Just RNil; _ -> Nothing) + (\RNil -> NoOpSilently) + +multiCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text +multiCounterDomainHandler = + DomainCommandHandler + { eventStream = multiCounterEventStream, + classifySilent = \_ -> error "multiCounterDomainHandler: eventful edge classified as silent" + } + +ambiguousCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text +ambiguousCounterDomainHandler = + DomainCommandHandler + { eventStream = ambiguousCounterEventStream, + classifySilent = \_ -> error "ambiguousCounterDomainHandler: no edge should be selected" + } + +silentChoiceDomainHandler :: DomainCommandHandler (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent Text Text +silentChoiceDomainHandler = + DomainCommandHandler + { eventStream = silentChoiceEventStream, + classifySilent = \SilentCommandContext {command = selectedCommand, selectedEdge} -> + case (selectedCommand, Keiki.edgeIndex selectedEdge) of + (RejectSilently, 0) -> SilentRejected "edge-0: rejected" + (NoOpSilently, 1) -> SilentNoOp "edge-1: already complete" + other -> error ("silentChoiceDomainHandler: unexpected selected edge " <> show other) + } + +retryDecisionDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent Text Text +retryDecisionDomainHandler = + DomainCommandHandler + { eventStream = retryDecisionEventStream, + classifySilent = \SilentCommandContext {state, selectedEdge} -> + case (state, Keiki.edgeIndex selectedEdge) of + (Drained, 0) -> SilentNoOp "already drained" + other -> error ("retryDecisionDomainHandler: unexpected selected edge " <> show other) + } + +feasibilityGateDomainHandler :: DomainCommandHandler (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent Text Text +feasibilityGateDomainHandler = + DomainCommandHandler + { eventStream = feasibilityGateEventStream, + classifySilent = \SilentCommandContext {state, selectedEdge} -> + case (state, Keiki.edgeIndex selectedEdge) of + (GateClosed, 0) -> SilentNoOp "gate closed" + other -> error ("feasibilityGateDomainHandler: unexpected selected edge " <> show other) + } + +strictFeasibilityGateEventStream :: ValidatedFeasibilityGateEventStream +strictFeasibilityGateEventStream = + mkEventStreamOrThrow + "reaction-strict-target" + feasibilityGateEventStreamDef {transducer = strictFeasibilityGateTransducer} + +strictFeasibilityGateTransducer :: SymTransducer (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent +strictFeasibilityGateTransducer = + feasibilityGateTransducer + { edgesOut = \case + GateClosed -> + [ Edge + { guard = matchInCtor openGateCtor, + update = UKeep, + output = [pack openGateCtor gateOpenedCtor oNil], + target = GateOpen, + mode = Keiki.Live + } + ] + GateOpen -> + [ Edge + { guard = matchInCtor tryAcceptCtor, + update = UKeep, + output = [pack tryAcceptCtor gateAcceptedCtor (inpCtor tryAcceptCtor #amount *: oNil)], + target = GateOpen, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor openGateCtor, + update = UKeep, + output = [], + target = GateOpen, + mode = Keiki.Live + } + ] + } + +coordinatorDomainHandler :: DomainCommandHandler (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent Text Text +coordinatorDomainHandler = + DomainCommandHandler + { eventStream = coordinatorEventStream, + classifySilent = \SilentCommandContext {command, selectedEdge} -> + case (command, Keiki.edgeIndex selectedEdge) of + (CoordinatorReject reason, 1) -> SilentRejected reason + (CoordinatorNoOp explanation, 2) -> SilentNoOp explanation + other -> error ("coordinatorDomainHandler: unexpected selected edge " <> show other) + } + +skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent +skipTransducer = + SymTransducer + { edgesOut = \case + Counting -> + [ Edge + { guard = matchInCtor sAddCtor, + update = UKeep, + output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)], + target = Counting, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor sSkipCtor, + update = UKeep, + output = [], + target = Counting, + mode = Keiki.Live + } + ], + initial = Counting, + initialRegs = RNil, + isFinal = \_ -> False + } + +sAddCtor :: InCtor SkipCommand AddFields +sAddCtor = + Keiki.unavailableInCtor + "SAdd" + ( \case + SAdd amount -> Just (RCons Proxy amount RNil) + SSkip -> Nothing + ) + ( \case + RCons _ amount RNil -> SAdd amount + ) + +sSkipCtor :: InCtor SkipCommand '[] +sSkipCtor = + Keiki.unavailableInCtor + "SSkip" + ( \case + SAdd {} -> Nothing + SSkip -> Just RNil + ) + ( \case + RNil -> SSkip + ) + +addCtor :: InCtor CounterCommand AddFields +addCtor = + Keiki.unavailableInCtor + "Add" + ( \case + Add amount -> Just (RCons Proxy amount RNil) + ) + ( \case + RCons _ amount RNil -> Add amount + ) + +counterAddedCtor :: WireCtor CounterEvent (Int, ()) +counterAddedCtor = + Keiki.unavailableWireCtor + "CounterAdded" + ( \case + CounterAdded amount -> Just (amount, ()) + CounterAudited {} -> Nothing + ) + ( \case + (amount, ()) -> CounterAdded amount + ) + +counterAuditedCtor :: WireCtor CounterEvent (Int, ()) +counterAuditedCtor = + Keiki.unavailableWireCtor + "CounterAudited" + ( \case + CounterAudited amount -> Just (amount, ()) + CounterAdded {} -> Nothing + ) + ( \case + (amount, ()) -> CounterAudited amount + ) + +counterCodec :: Codec CounterEvent +counterCodec = + Codec + { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"], + eventType = \case + CounterAdded {} -> EventType "CounterAdded" + CounterAudited {} -> EventType "CounterAudited", + schemaVersion = 1, + encode = \case + CounterAdded amount -> object ["amount" Aeson..= amount] + CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True], + decode = parseCounterEvent, + upcasters = [] + } + +parseCounterEvent :: EventType -> Value -> Either Text CounterEvent +parseCounterEvent (EventType tag) value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "CounterEvent" $ \objectValue -> do + amount <- objectValue .: "amount" + case tag of + "CounterAdded" -> pure (CounterAdded amount) + "CounterAudited" -> pure (CounterAudited amount) + _ -> fail "unknown counter event type" + +-- * Divert fixture (plan 143: replay-only transitions / black-acuity) ----- + +type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent + +type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent + +data DivertCommand + = ConfirmDivert !Bool + deriving stock (Generic, Eq, Show) + +newtype DivertEvent + = DivertConfirmed Bool + deriving stock (Generic, Eq, Show) + +data DivertState + = DivertHeld + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + +type DivertFields = '[ '("acuityBlack", Bool)] + +confirmDivertCtor :: InCtor DivertCommand DivertFields +confirmDivertCtor = + Keiki.unavailableInCtor + "ConfirmDivert" + ( \case + ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil) + ) + ( \case + RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack + ) + +divertConfirmedCtor :: WireCtor DivertEvent (Bool, ()) +divertConfirmedCtor = + Keiki.unavailableWireCtor + "DivertConfirmed" + ( \case + DivertConfirmed acuityBlack -> Just (acuityBlack, ()) + ) + ( \case + (acuityBlack, ()) -> DivertConfirmed acuityBlack + ) + +divertCodec :: Codec DivertEvent +divertCodec = + Codec + { eventTypes = EventType "DivertConfirmed" :| [], + eventType = \_ -> EventType "DivertConfirmed", + schemaVersion = 1, + encode = \case + DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack], + decode = parseDivertEvent, + upcasters = [] + } + +parseDivertEvent :: EventType -> Value -> Either Text DivertEvent +parseDivertEvent _ value = + case parseEither parser value of + Right event -> Right event + Left message -> Left (fromStringLiteral message) + where + parser = withObject "DivertConfirmed" $ \objectValue -> + DivertConfirmed <$> objectValue .: "acuityBlack" + +-- | The old rule: confirm any reservation. +divertOldGuard :: HsPred '[] DivertCommand +divertOldGuard = matchInCtor confirmDivertCtor + +-- | The tightened rule: confirm only non-black acuity. +divertNewGuard :: HsPred '[] DivertCommand +divertNewGuard = + PAnd + (matchInCtor confirmDivertCtor) + (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False) + +-- | The removed region, @old ∧ ¬new@: exactly black acuity. +divertRemovedRegionGuard :: HsPred '[] DivertCommand +divertRemovedRegionGuard = + PAnd + (matchInCtor confirmDivertCtor) + (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True) + +divertConfirmEdge :: + HsPred '[] DivertCommand -> + Keiki.EdgeMode -> + Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState +divertConfirmEdge edgeGuard edgeMode = + Edge + { guard = edgeGuard, + update = UKeep, + output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)], + target = DivertHeld, + mode = edgeMode + } + +divertEventStreamDef :: + [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] -> + DivertEventStream +divertEventStreamDef heldEdges = + EventStream + { transducer = + SymTransducer + { edgesOut = \case + DivertHeld -> heldEdges, + initial = DivertHeld, + initialRegs = RNil, + isFinal = const False + }, + initialState = DivertHeld, + initialRegisters = RNil, + eventCodec = divertCodec, + resolveStreamName = Stream.streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +-- | Machine A: the original permissive rule. +permissiveDivertEventStream :: ValidatedDivertEventStream +permissiveDivertEventStream = + mkEventStreamOrThrow + "divert-permissive" + (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live]) + +-- | Machine B without the twin: the tightened rule alone. +tightenedDivertEventStream :: ValidatedDivertEventStream +tightenedDivertEventStream = + mkEventStreamOrThrow + "divert-tightened" + (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live]) + +-- | Machine B with the replay-only twin carrying the removed region: +-- the tightened rule governs new traffic; black-acuity history keeps +-- its inverting edge. +twinDivertEventStream :: ValidatedDivertEventStream +twinDivertEventStream = + mkEventStreamOrThrow + "divert-twin" + ( divertEventStreamDef + [ divertConfirmEdge divertNewGuard Keiki.Live, + divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly + ] + ) + +domainProcessManager :: + DomainProcessManager + DomainDispatchInput + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CoordinatorCommand) + '[] + CounterState + CoordinatorCommand + CounterEvent + Text + Text +domainProcessManager = + DomainProcessManager + { name = "domain-pm", + correlate = \(DomainDispatchInput correlationId _) -> correlationId, + eventStream = counterEventStream, + streamFor = \correlationId -> stream ("domain-pm:" <> correlationId), + targetHandler = coordinatorDomainHandler, + targetProjections = const [], + handle = \(DomainDispatchInput correlationId targetCommands) -> + ProcessManagerAction + { command = Add 1, + commands = + Prelude.zipWith + (\targetIndex targetCommand -> PMCommand {target = stream ("domain-pm-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand}) + [0 :: Int ..] + targetCommands, + timers = [] + } + } + +domainRouter :: + DomainRouter + DomainDispatchInput + (HsPred '[] CoordinatorCommand) + '[] + CounterState + CoordinatorCommand + CounterEvent + Text + Text + es +domainRouter = + DomainRouter + { name = "domain-router", + key = \(DomainDispatchInput correlationId _) -> correlationId, + resolve = \(DomainDispatchInput correlationId targetCommands) -> + pure + ( Prelude.zipWith + (\targetIndex targetCommand -> PMCommand {target = stream ("domain-router-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand}) + [0 :: Int ..] + targetCommands + ), + targetHandler = coordinatorDomainHandler, + targetProjections = const [] + } + +counterProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +counterProcessManager = + ProcessManager + { name = "counter-pm", + correlate = \_ -> "order-1", + eventStream = counterEventStream, + streamFor = \correlationId -> stream ("pm:counter-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = + [ PMCommand + { target = stream "counter-target-order-1", + command = Add amount + } + ], + timers = [counterTimerRequest] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +type CounterReactionInput = (Text, Reaction.ReactionPlan CounterCommand CounterCommand) + +counterReactionManager :: + Reaction.ReactiveProcessManager + CounterReactionInput + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + Text + Text +counterReactionManager = + Reaction.ReactiveProcessManager + "counter-reaction" + Prelude.fst + multiCounterDomainHandler + (\correlationId -> stream ("reaction-saga:" <> correlationId)) + counterEventStream + (const []) + Prelude.snd + +type SilentReactionInput = (Text, Reaction.ReactionPlan SilentChoiceCommand CounterCommand) + +silentReactionManager :: + Reaction.ReactiveProcessManager + SilentReactionInput + (HsPred '[] SilentChoiceCommand) + '[] + CounterState + SilentChoiceCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + Text + Text +silentReactionManager = + Reaction.ReactiveProcessManager + "silent-reaction" + Prelude.fst + silentChoiceDomainHandler + (\correlationId -> stream ("reaction-silent-saga:" <> correlationId)) + counterEventStream + (const []) + Prelude.snd + +retryTargetReactionManager :: + Reaction.ReactiveProcessManager + CounterReactionInput + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + DrainState + CounterCommand + CounterEvent + Text + Text +retryTargetReactionManager = + Reaction.ReactiveProcessManager + "retry-target-reaction" + Prelude.fst + multiCounterDomainHandler + (\correlationId -> stream ("reaction-retry-saga:" <> correlationId)) + retryDecisionEventStream + (const []) + Prelude.snd + +type StrictTargetReactionInput = (Text, Reaction.ReactionPlan CounterCommand FeasibilityGateCommand) + +strictTargetReactionManager :: + Reaction.ReactiveProcessManager + StrictTargetReactionInput + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] FeasibilityGateCommand) + '[] + FeasibilityGateState + FeasibilityGateCommand + FeasibilityGateEvent + Text + Text +strictTargetReactionManager = + Reaction.ReactiveProcessManager + "strict-target-reaction" + Prelude.fst + multiCounterDomainHandler + (\correlationId -> stream ("reaction-strict-saga:" <> correlationId)) + strictFeasibilityGateEventStream + (const []) + Prelude.snd + +unicodeCounterProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +unicodeCounterProcessManager = + counterProcessManager + { name = "unicode-pm", + correlate = const "\x4E2D\x6587-42", + streamFor = const (stream "pm:counter-unicode"), + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = [PMCommand {target = stream "counter-target-unicode", command = Add amount}], + timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +timerOnlyProcessManager :: + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +timerOnlyProcessManager = + ProcessManager + { name = "timer-only-pm", + correlate = \_ -> "order-1", + eventStream = noOpCounterEventStream, + streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = + [ counterTimerRequest + & #processManagerName + .~ "timer-only-pm" + ] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +-- A process manager whose OWN state stream snapshots under Every 2. +-- This is the first PM fixture to exercise a state-stream snapshot: the only +-- difference from counterProcessManager is that its eventStream carries a +-- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so +-- runProcessManagerOnce's manager-state append (which goes through +-- runCommandWithSql) writes and reuses snapshots. The manager registers are +-- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream; +-- the target side stays '[]/counterEventStream exactly as counterProcessManager. +pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream +pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef + +pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream +pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef + +pmSnapshotProcessManager :: + ProcessManager + CounterEvent + (HsPred SnapshotCounterRegs CounterCommand) + SnapshotCounterRegs + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +pmSnapshotProcessManager = + ProcessManager + { name = "counter-snap-pm", + correlate = \_ -> "order-1", + eventStream = pmSnapshotCounterEventStream, + streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId), + targetEventStream = counterEventStream, + targetProjections = const [], + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = [], -- keep the test focused on the manager state stream + timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +workflowProcessManager :: + Text -> + Text -> + Text -> + ProcessManager + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent + (HsPred '[] CounterCommand) + '[] + CounterState + CounterCommand + CounterEvent +workflowProcessManager managerName managerCategory targetStreamName = + counterProcessManager + { name = managerName, + streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId), + handle = \case + CounterAdded amount -> + ProcessManagerAction + { command = Add amount, + commands = + [ PMCommand + { target = stream targetStreamName, + command = Add amount + } + ], + timers = [] + } + CounterAudited amount -> + ProcessManagerAction + { command = Add amount, + commands = [], + timers = [] + } + } + +assertWorkflowProcessManagerAppended :: + Either + Store.StoreError + ( Either + CommandError + (ProcessManagerResult CounterEventStream CounterEventStream) + ) -> + Expectation +assertWorkflowProcessManagerAppended = \case + Right (Right pmResult) -> do + pmResult ^. #managerResult `shouldSatisfy` \case + PMStateAppended {} -> True + _ -> False + pmResult ^. #commandResults `shouldSatisfy` \case + [PMCommandAppended {}] -> True + _ -> False + other -> expectationFailure ("expected workflow process-manager success, got " <> show other) + +counterTimerRequest :: TimerRequest +counterTimerRequest = + TimerRequest + { timerId = TimerId sampleUuid, + processManagerName = "counter-pm", + correlationId = "order-1", + fireAt = dueTimerTime, + payload = object ["kind" Aeson..= ("counter-timeout" :: Text)] + } + +dueTimerTime :: UTCTime +dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + +reactionTimerFailureTriggerSql :: ByteString +reactionTimerFailureTriggerSql = + """ + CREATE OR REPLACE FUNCTION keiro.fail_reaction_timer() + RETURNS trigger LANGUAGE plpgsql AS $$ + BEGIN + IF NEW.process_manager_name = 'reaction-fail' THEN + RAISE EXCEPTION 'injected reaction timer failure'; + END IF; + RETURN NEW; + END; + $$; + CREATE TRIGGER fail_reaction_timer + BEFORE INSERT OR UPDATE ON keiro.keiro_timers + FOR EACH ROW EXECUTE FUNCTION keiro.fail_reaction_timer(); + """ -- | An ordinary (non-sleep) process-manager timer, already due, distinguished -- only by index. Used to build a drainable backlog. diff --git a/test/ReactionExample.hs b/test/ReactionExample.hs new file mode 100644 --- /dev/null +++ b/test/ReactionExample.hs @@ -0,0 +1,370 @@ +module ReactionExample + ( ExampleInput (..), + Severity (..), + ExampleSagaCommand (..), + ExampleSagaEvent (..), + ExampleTargetCommand (..), + ExampleTargetEvent (..), + ExampleSagaStream, + ExampleTargetStream, + exampleReactionManager, + exampleTargetEventStream, + exampleReminderTimerId, + exampleEscalationTimerId, + ) +where + +import Data.Aeson (FromJSON, ToJSON, object, withObject, (.:)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser, parseEither) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time (UTCTime, addUTCTime) +import Data.UUID qualified as UUID +import GHC.Generics (Generic) +import Keiki.Core + ( Edge (..), + HsPred, + InCtor, + RegFile (..), + SymTransducer (..), + Update (..), + WireCtor, + inpCtor, + matchInCtor, + oNil, + pack, + (*:), + ) +import Keiki.Core qualified as Keiki +import Keiki.Shape (CanonicalStateShape) +import Keiro.Codec (Codec (..)) +import Keiro.Command (DomainCommandHandler (..), SilentDomainDecision (..)) +import Keiro.EventStream (EventStream (..), SnapshotPolicy (..)) +import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow) +import Keiro.ProcessManager (PMCommand (..)) +import Keiro.ProcessManager.Reaction qualified as Reaction +import Keiro.Stream (stream, streamName) +import Keiro.Timer (TimerId (..), TimerRequest (..)) +import Kiroku.Store.Types (EventType (..)) + +data Severity = Routine | Urgent + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data ExampleInput + = IncidentReported !Text !Severity + | IncidentAcknowledged !Text + deriving stock (Generic, Eq, Show) + +data ExampleSagaCommand + = RecordIncident !Severity + | RecordAcknowledgement + deriving stock (Generic, Eq, Show) + +data ExampleSagaEvent + = IncidentRecorded !Severity + | AcknowledgementRecorded + deriving stock (Generic, Eq, Show) + +data ExampleSagaState = Tracking + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape ExampleSagaState + +data ExampleTargetCommand + = SendAlert !Text + | ApplyLateTimeout + deriving stock (Generic, Eq, Show) + +data ExampleTargetEvent + = AlertSent !Text + | LateTimeoutApplied + deriving stock (Generic, Eq, Show) + +data ExampleTargetState = AwaitingAlert | AlertComplete + deriving stock (Generic, Eq, Show, Enum, Bounded, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance CanonicalStateShape ExampleTargetState + +type SeverityFields = '[ '("severity", Severity)] + +type CorrelationFields = '[ '("correlationId", Text)] + +type ExampleSagaStream = EventStream (HsPred '[] ExampleSagaCommand) '[] ExampleSagaState ExampleSagaCommand ExampleSagaEvent + +type ExampleTargetStream = EventStream (HsPred '[] ExampleTargetCommand) '[] ExampleTargetState ExampleTargetCommand ExampleTargetEvent + +exampleReactionManager :: + UTCTime -> + Reaction.ReactiveProcessManager + ExampleInput + (HsPred '[] ExampleSagaCommand) + '[] + ExampleSagaState + ExampleSagaCommand + ExampleSagaEvent + (HsPred '[] ExampleTargetCommand) + '[] + ExampleTargetState + ExampleTargetCommand + ExampleTargetEvent + Text + Text +exampleReactionManager injectedNow = + Reaction.ReactiveProcessManager + { name = "incident-reaction-example", + correlate = \case + IncidentReported correlationId _ -> correlationId + IncidentAcknowledged correlationId -> correlationId, + sagaHandler = exampleSagaHandler, + streamFor = \correlationId -> stream ("incident-reaction-saga:" <> correlationId), + targetEventStream = exampleTargetEventStream, + targetProjections = const [], + react = \case + IncidentReported _ Routine -> Reaction.NoAdvance [] + IncidentReported correlationId Urgent -> + Reaction.AdvanceReaction + { command = RecordIncident Urgent, + followUps = + [ Reaction.FollowSchedule Reaction.Once (reminderTimer correlationId), + Reaction.FollowSchedule Reaction.Once (escalationTimer correlationId) + ], + onAccepted = + [ Reaction.FollowDispatch + (PMCommand (stream ("incident-reaction-target:" <> correlationId)) (SendAlert correlationId)) + ] + } + IncidentAcknowledged _ -> + Reaction.AdvanceReaction + { command = RecordAcknowledgement, + followUps = + [ Reaction.FollowCancel exampleReminderTimerId, + Reaction.FollowCancel exampleEscalationTimerId + ], + onAccepted = [] + } + } + where + reminderTimer correlationId = + TimerRequest + { timerId = exampleReminderTimerId, + processManagerName = "incident-reaction-example-reminder", + correlationId, + fireAt = addUTCTime 300 injectedNow, + payload = object ["kind" Aeson..= ("reminder" :: Text), "correlationId" Aeson..= correlationId] + } + escalationTimer correlationId = + TimerRequest + { timerId = exampleEscalationTimerId, + processManagerName = "incident-reaction-example-escalation", + correlationId, + fireAt = addUTCTime 900 injectedNow, + payload = object ["kind" Aeson..= ("escalation" :: Text), "correlationId" Aeson..= correlationId] + } + +exampleReminderTimerId :: TimerId +exampleReminderTimerId = TimerId (UUID.fromWords 0x27900001 0 0 1) + +exampleEscalationTimerId :: TimerId +exampleEscalationTimerId = TimerId (UUID.fromWords 0x27900002 0 0 2) + +exampleSagaHandler :: DomainCommandHandler (HsPred '[] ExampleSagaCommand) '[] ExampleSagaState ExampleSagaCommand ExampleSagaEvent Text Text +exampleSagaHandler = + DomainCommandHandler + { eventStream = exampleSagaEventStream, + classifySilent = \_ -> SilentNoOp "already acknowledged" + } + +exampleSagaEventStream :: ValidatedEventStream (HsPred '[] ExampleSagaCommand) '[] ExampleSagaState ExampleSagaCommand ExampleSagaEvent +exampleSagaEventStream = mkEventStreamOrThrow "reaction-example-saga" exampleSagaEventStreamDef + +exampleSagaEventStreamDef :: ExampleSagaStream +exampleSagaEventStreamDef = + EventStream + { transducer = exampleSagaTransducer, + initialState = Tracking, + initialRegisters = RNil, + eventCodec = exampleSagaCodec, + resolveStreamName = streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +exampleSagaTransducer :: SymTransducer (HsPred '[] ExampleSagaCommand) '[] ExampleSagaState ExampleSagaCommand ExampleSagaEvent +exampleSagaTransducer = + SymTransducer + { edgesOut = \Tracking -> + [ Edge + { guard = matchInCtor recordIncidentCtor, + update = UKeep, + output = [pack recordIncidentCtor incidentRecordedCtor (inpCtor recordIncidentCtor #severity *: oNil)], + target = Tracking, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor recordAcknowledgementCtor, + update = UKeep, + output = [pack recordAcknowledgementCtor acknowledgementRecordedCtor oNil], + target = Tracking, + mode = Keiki.Live + } + ], + initial = Tracking, + initialRegs = RNil, + isFinal = const False + } + +exampleTargetEventStream :: ValidatedEventStream (HsPred '[] ExampleTargetCommand) '[] ExampleTargetState ExampleTargetCommand ExampleTargetEvent +exampleTargetEventStream = mkEventStreamOrThrow "reaction-example-target" exampleTargetEventStreamDef + +exampleTargetEventStreamDef :: ExampleTargetStream +exampleTargetEventStreamDef = + EventStream + { transducer = exampleTargetTransducer, + initialState = AwaitingAlert, + initialRegisters = RNil, + eventCodec = exampleTargetCodec, + resolveStreamName = streamName, + snapshotPolicy = Never, + stateCodec = Nothing + } + +exampleTargetTransducer :: SymTransducer (HsPred '[] ExampleTargetCommand) '[] ExampleTargetState ExampleTargetCommand ExampleTargetEvent +exampleTargetTransducer = + SymTransducer + { edgesOut = \case + AwaitingAlert -> + [ Edge + { guard = matchInCtor sendAlertCtor, + update = UKeep, + output = [pack sendAlertCtor alertSentCtor (inpCtor sendAlertCtor #correlationId *: oNil)], + target = AlertComplete, + mode = Keiki.Live + }, + Edge + { guard = matchInCtor applyLateTimeoutCtor, + update = UKeep, + output = [pack applyLateTimeoutCtor lateTimeoutAppliedCtor oNil], + target = AlertComplete, + mode = Keiki.Live + } + ] + AlertComplete -> + [ Edge + { guard = matchInCtor applyLateTimeoutCtor, + update = UKeep, + output = [], + target = AlertComplete, + mode = Keiki.Live + } + ], + initial = AwaitingAlert, + initialRegs = RNil, + isFinal = const False + } + +recordIncidentCtor :: InCtor ExampleSagaCommand SeverityFields +recordIncidentCtor = + Keiki.unavailableInCtor + "RecordIncident" + (\case RecordIncident severity -> Just (RCons Proxy severity RNil); RecordAcknowledgement -> Nothing) + (\case RCons _ severity RNil -> RecordIncident severity) + +recordAcknowledgementCtor :: InCtor ExampleSagaCommand '[] +recordAcknowledgementCtor = + Keiki.unavailableInCtor + "RecordAcknowledgement" + (\case RecordAcknowledgement -> Just RNil; RecordIncident {} -> Nothing) + (\RNil -> RecordAcknowledgement) + +incidentRecordedCtor :: WireCtor ExampleSagaEvent (Severity, ()) +incidentRecordedCtor = + Keiki.unavailableWireCtor + "IncidentRecorded" + (\case IncidentRecorded severity -> Just (severity, ()); AcknowledgementRecorded -> Nothing) + (\(severity, ()) -> IncidentRecorded severity) + +acknowledgementRecordedCtor :: WireCtor ExampleSagaEvent () +acknowledgementRecordedCtor = + Keiki.unavailableWireCtor + "AcknowledgementRecorded" + (\case AcknowledgementRecorded -> Just (); IncidentRecorded {} -> Nothing) + (const AcknowledgementRecorded) + +sendAlertCtor :: InCtor ExampleTargetCommand CorrelationFields +sendAlertCtor = + Keiki.unavailableInCtor + "SendAlert" + (\case SendAlert correlationId -> Just (RCons Proxy correlationId RNil); ApplyLateTimeout -> Nothing) + (\case RCons _ correlationId RNil -> SendAlert correlationId) + +applyLateTimeoutCtor :: InCtor ExampleTargetCommand '[] +applyLateTimeoutCtor = + Keiki.unavailableInCtor + "ApplyLateTimeout" + (\case ApplyLateTimeout -> Just RNil; SendAlert {} -> Nothing) + (\RNil -> ApplyLateTimeout) + +alertSentCtor :: WireCtor ExampleTargetEvent (Text, ()) +alertSentCtor = + Keiki.unavailableWireCtor + "AlertSent" + (\case AlertSent correlationId -> Just (correlationId, ()); LateTimeoutApplied -> Nothing) + (\(correlationId, ()) -> AlertSent correlationId) + +lateTimeoutAppliedCtor :: WireCtor ExampleTargetEvent () +lateTimeoutAppliedCtor = + Keiki.unavailableWireCtor + "LateTimeoutApplied" + (\case LateTimeoutApplied -> Just (); AlertSent {} -> Nothing) + (const LateTimeoutApplied) + +exampleSagaCodec :: Codec ExampleSagaEvent +exampleSagaCodec = + Codec + { eventTypes = EventType "IncidentRecorded" :| [EventType "AcknowledgementRecorded"], + eventType = \case + IncidentRecorded {} -> EventType "IncidentRecorded" + AcknowledgementRecorded -> EventType "AcknowledgementRecorded", + schemaVersion = 1, + encode = \case + IncidentRecorded severity -> object ["severity" Aeson..= severity] + AcknowledgementRecorded -> object [], + decode = \eventType value -> parseCodec eventType value $ \objectValue -> case eventType of + EventType "IncidentRecorded" -> IncidentRecorded <$> objectValue .: "severity" + EventType "AcknowledgementRecorded" -> pure AcknowledgementRecorded + _ -> fail "unknown example saga event", + upcasters = [] + } + +exampleTargetCodec :: Codec ExampleTargetEvent +exampleTargetCodec = + Codec + { eventTypes = EventType "AlertSent" :| [EventType "LateTimeoutApplied"], + eventType = \case + AlertSent {} -> EventType "AlertSent" + LateTimeoutApplied -> EventType "LateTimeoutApplied", + schemaVersion = 1, + encode = \case + AlertSent correlationId -> object ["correlationId" Aeson..= correlationId] + LateTimeoutApplied -> object [], + decode = \eventType value -> parseCodec eventType value $ \objectValue -> case eventType of + EventType "AlertSent" -> AlertSent <$> objectValue .: "correlationId" + EventType "LateTimeoutApplied" -> pure LateTimeoutApplied + _ -> fail "unknown example target event", + upcasters = [] + } + +parseCodec :: EventType -> Aeson.Value -> (Aeson.Object -> Parser event) -> Either Text event +parseCodec eventType value parser = + case parseEither (withObject (Text.unpack (coerceEventType eventType)) parser) value of + Left message -> Left (Text.pack message) + Right decoded -> Right decoded + +coerceEventType :: EventType -> Text +coerceEventType (EventType eventType) = eventType