keiro-test-support 0.17.0.0 → 0.18.0.0

raw patch · 5 files changed

+809/−5 lines, 5 filesdep +directorydep +hspecdep +keiro-test-supportdep ~ephemeral-pgdep ~keiro-migrationsPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, hspec, keiro-test-support, unix

Dependency ranges changed: ephemeral-pg, keiro-migrations

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• keiro-test-support.cabal +28/−4
• src/Keiro/Test/Postgres.hs +23/−1
• src/Keiro/Test/ReplayCompatibility.hs +556/−0
• test/Main.hs +179/−0

@@ -6,6 +6,29 @@  ## [Unreleased] +## 0.18.0.0 — 2026-09-20+++### New Features++- New exposed module `Keiro.Test.ReplayCompatibility` defines the versioned,+  build-bound replay capture report and the independently derived inventory+  contract that gate mapping evolution. A report that is missing, unverified,+  empty, duplicated, or divergent from its required observations is rejected+  rather than silently accepted. The package now carries its own+  `keiro-test-support-test` suite covering those rejections.++### Other Changes++- Require `ephemeral-pg >=0.3.1 && <0.4`. The suite fixture now starts its+  server under a stable per-user temporary root, `/tmp/ephpg-keiro-<uid>`,+  instead of `$TMPDIR`, so ephemeral-pg's startup sweep reclaims PostgreSQL+  clusters abandoned by earlier killed runs even when `$TMPDIR` is per-session+  (`nix develop`, some CI runners). Consumers whose build plan also pulls in+  `pg-migrate-test-support 1.1.0.0` need+  `allow-newer: pg-migrate-test-support:ephemeral-pg` in their `cabal.project`+  until a Hackage revision widens that cap.+ ## 0.17.0.0 — 2026-09-17  ### New Features

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-test-support-version: 0.17.0.0+version: 0.18.0.0 synopsis: Shared PostgreSQL test fixtures for Keiro test suites description:   Suite-level ephemeral-PostgreSQL fixtures shared by the Keiro test@@ -44,19 +44,43 @@     OverloadedRecordDot     OverloadedStrings -  exposed-modules: Keiro.Test.Postgres+  exposed-modules:+    Keiro.Test.Postgres+    Keiro.Test.ReplayCompatibility+   hs-source-dirs: src   build-depends:     aeson >=2.2 && <2.3,     base >=4.21 && <5,     containers >=0.6 && <0.8,+    directory >=1.3 && <1.4,     effectful >=2.6 && <2.7,-    ephemeral-pg >=0.2 && <0.3,+    ephemeral-pg >=0.3.1 && <0.4,     hasql >=1.10 && <1.11,     hasql-pool >=1.2 && <1.5,-    keiro-migrations ^>=0.17.0.0,+    keiro-migrations ^>=0.18.0.0,     kiroku-store >=0.8 && <0.9,     kiroku-store-migrations ^>=0.4.0.0,     pg-migrate ^>=1.1.0.0,     stm >=2.5 && <2.6,+    text >=2.1 && <2.2,+    unix >=2.8 && <2.9,++test-suite keiro-test-support-test+  import: warnings+  type: exitcode-stdio-1.0+  default-language: GHC2024+  default-extensions:+    BlockArguments+    OverloadedRecordDot+    OverloadedStrings++  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    aeson >=2.2 && <2.3,+    base >=4.21 && <5,+    containers >=0.6 && <0.8,+    hspec >=2.11,+    keiro-test-support,     text >=2.1 && <2.2,

@@ -39,6 +39,7 @@ import Control.Concurrent.STM (TVar, atomically, newTVarIO, stateTVar) import Control.Exception (bracket, onException) import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid (Last (..)) import Data.Text (Text) import Data.Text qualified as Text import Database.PostgreSQL.Migrate (MigrationComponent, defaultRunOptions, migrationPlan, runMigrationPlan)@@ -55,6 +56,8 @@ import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore, withKirokuStore) import Kiroku.Store.Error (StoreError) import Kiroku.Store.Migrations qualified as Kiroku+import System.Directory (createDirectoryIfMissing)+import System.Posix.User (getEffectiveUserID)  -- | A running, migrated suite fixture: one cached PostgreSQL server owning a -- single migrated template database, plus a counter for unique clone names.@@ -67,6 +70,24 @@ templateDbName :: Text templateDbName = "keiro_template" +-- | The ephemeral PostgreSQL configuration for Keiro suites: 'Pg.defaultConfig'+-- with a stable, per-user temporary root.+--+-- ephemeral-pg sweeps clusters abandoned by killed runs on the next startup, but+-- only inside the configured temporary root. Left unset, the root is @$TMPDIR@,+-- which @nix develop@ and some CI runners make per-session, so each run sweeps an+-- empty directory and orphaned postmasters accumulate. A fixed root shared by+-- every Keiro suite lets any run reclaim what an earlier run left behind. The+-- effective uid keys the root so a build sandbox running as another user does not+-- collide with a developer's @0700@ directory. The keiro-migrations test suites+-- use the same root.+ephemeralPgConfig :: IO Pg.Config+ephemeralPgConfig = do+  uid <- getEffectiveUserID+  let root = "/tmp/ephpg-keiro-" <> show uid+  createDirectoryIfMissing True root+  pure Pg.defaultConfig {Pg.temporaryRoot = Last (Just root)}+ -- | Start one cached PostgreSQL server, create a template database, apply the -- Kiroku event-store schema and Keiro framework schema to it once, then run -- @action@ with the resulting 'Fixture'. The server is stopped on exit.@@ -89,7 +110,8 @@ -- @UnknownStoredMigration@. withMigratedSuiteWith :: [MigrationComponent] -> (Fixture -> IO a) -> IO a withMigratedSuiteWith extraComponents action = do-  started <- Pg.startCached Pg.defaultConfig Pg.defaultCacheConfig+  config <- ephemeralPgConfig+  started <- Pg.startCached config Pg.defaultCacheConfig   case started of     Left err -> fail (Text.unpack (Pg.renderStartError err))     Right server ->

@@ -0,0 +1,556 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | Stable, application-neutral evidence for comparing retained history across+-- two independently built versions of a service.+--+-- Capture programs should link only one application version. They emit a+-- 'CaptureReport'; a separate comparator loads the baseline report, candidate+-- report, and independently generated 'EvidenceInventory'. This avoids making+-- old and new domain types coexist in one executable.+module Keiro.Test.ReplayCompatibility+  ( BuildIdentity (..),+    BuildPair (..),+    CaptureRole (..),+    CaseKind (..),+    PersistedSurface (..),+    RequiredCase (..),+    InventorySource (..),+    SourceApplicability (..),+    InventoryContribution (..),+    EvidenceInventory (..),+    HighWaterMark (..),+    DeterminismInputs (..),+    Observation (..),+    EvidenceVerdict (..),+    CaseResult (..),+    CaptureReport (..),+    CompatibilityFailure (..),+    NormalizationFailure (..),+    inventorySourcesV1,+    inventoryVersionV1,+    reportVersionV1,+    requiredCases,+    validateCompatibility,+    compareObservation,+    releaseReady,+    renderCompatibilityFailure,+    checkNormalizationLaw,+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..), Value)+import Data.Aeson qualified as Aeson+import Data.Aeson.Types (Parser)+import Data.List (group, sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)++reportVersionV1 :: Text+reportVersionV1 = "keiro.replay-compatibility/report/v1"++inventoryVersionV1 :: Text+inventoryVersionV1 = "keiro.replay-compatibility/inventory/v1"++data BuildIdentity = BuildIdentity+  { sourceRevision :: Text,+    languageProfile :: Text,+    runtimeProfile :: Text,+    dependencyPlanHash :: Text+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON BuildIdentity++instance FromJSON BuildIdentity++data BuildPair = BuildPair+  { baseline :: BuildIdentity,+    candidate :: BuildIdentity+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON BuildPair++instance FromJSON BuildPair++data CaptureRole = BaselineCapture | CandidateCapture+  deriving stock (Eq, Ord, Show)++instance ToJSON CaptureRole where+  toJSON = Aeson.String . captureRoleToken++instance FromJSON CaptureRole where+  parseJSON = Aeson.withText "CaptureRole" $ parseToken "capture role" captureRoles++captureRoleToken :: CaptureRole -> Text+captureRoleToken = \case+  BaselineCapture -> "baseline"+  CandidateCapture -> "candidate"++captureRoles :: [(Text, CaptureRole)]+captureRoles = [(captureRoleToken role, role) | role <- [BaselineCapture, CandidateCapture]]++data CaseKind+  = HistoricalRead+  | SemanticEquivalence+  | OldReaderNewWriter+  | SnapshotReplay+  | ProcessManagerReplay+  | WorkflowReplay+  deriving stock (Eq, Ord, Show, Enum, Bounded)++instance ToJSON CaseKind where+  toJSON = Aeson.String . caseKindToken++instance FromJSON CaseKind where+  parseJSON = Aeson.withText "CaseKind" $ parseToken "case kind" caseKinds++caseKindToken :: CaseKind -> Text+caseKindToken = \case+  HistoricalRead -> "historical-read"+  SemanticEquivalence -> "semantic-equivalence"+  OldReaderNewWriter -> "old-reader-new-writer"+  SnapshotReplay -> "snapshot"+  ProcessManagerReplay -> "process-manager"+  WorkflowReplay -> "workflow"++caseKinds :: [(Text, CaseKind)]+caseKinds = [(caseKindToken kind, kind) | kind <- [minBound .. maxBound]]++data PersistedSurface = PersistedSurface+  { kind :: Text,+    owner :: Text,+    identity :: Text+  }+  deriving stock (Eq, Ord, Show, Generic)++instance ToJSON PersistedSurface++instance FromJSON PersistedSurface++data RequiredCase = RequiredCase+  { caseId :: Text,+    caseKind :: CaseKind,+    surface :: PersistedSurface+  }+  deriving stock (Eq, Ord, Show, Generic)++instance ToJSON RequiredCase++instance FromJSON RequiredCase++-- | Every v1 inventory names all of these inputs. An input may explicitly be+-- not applicable, but it may not disappear merely because a candidate report+-- omitted its cases.+data InventorySource+  = BaselinePersistedSurfaces+  | CandidatePersistedSurfaces+  | OrdinaryCompatibilityFindings+  | AggregateReplayImpacts+  | MappedConsequences+  | CheckedProcessReactions+  | ApplicationOwnedObligations+  deriving stock (Eq, Ord, Show, Enum, Bounded)++inventorySourcesV1 :: [InventorySource]+inventorySourcesV1 = [minBound .. maxBound]++instance ToJSON InventorySource where+  toJSON = Aeson.String . inventorySourceToken++instance FromJSON InventorySource where+  parseJSON = Aeson.withText "InventorySource" $ parseToken "inventory source" inventorySources++inventorySourceToken :: InventorySource -> Text+inventorySourceToken = \case+  BaselinePersistedSurfaces -> "baseline-persisted-surfaces"+  CandidatePersistedSurfaces -> "candidate-persisted-surfaces"+  OrdinaryCompatibilityFindings -> "ordinary-compatibility-findings"+  AggregateReplayImpacts -> "aggregate-replay-impacts"+  MappedConsequences -> "mapped-consequences"+  CheckedProcessReactions -> "checked-process-reactions"+  ApplicationOwnedObligations -> "application-owned-obligations"++inventorySources :: [(Text, InventorySource)]+inventorySources = [(inventorySourceToken source, source) | source <- inventorySourcesV1]++data SourceApplicability+  = Applicable+  | NotApplicable Text+  | SourceUnverified Text+  deriving stock (Eq, Show)++instance ToJSON SourceApplicability where+  toJSON = \case+    Applicable -> Aeson.object ["status" Aeson..= ("applicable" :: Text)]+    NotApplicable reason -> Aeson.object ["status" Aeson..= ("not-applicable" :: Text), "reason" Aeson..= reason]+    SourceUnverified reason -> Aeson.object ["status" Aeson..= ("unverified" :: Text), "reason" Aeson..= reason]++instance FromJSON SourceApplicability where+  parseJSON = Aeson.withObject "SourceApplicability" $ \object -> do+    status <- object Aeson..: "status"+    case status :: Text of+      "applicable" -> pure Applicable+      "not-applicable" -> NotApplicable <$> object Aeson..: "reason"+      "unverified" -> SourceUnverified <$> object Aeson..: "reason"+      other -> fail ("unsupported inventory applicability: " <> Text.unpack other)++data InventoryContribution = InventoryContribution+  { source :: InventorySource,+    applicability :: SourceApplicability,+    cases :: [RequiredCase]+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON InventoryContribution++instance FromJSON InventoryContribution++data EvidenceInventory = EvidenceInventory+  { inventoryVersion :: Text,+    inventoryId :: Text,+    buildPair :: BuildPair,+    contributions :: [InventoryContribution]+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON EvidenceInventory++instance FromJSON EvidenceInventory++data HighWaterMark = HighWaterMark+  { stream :: Text,+    revision :: Integer+  }+  deriving stock (Eq, Ord, Show, Generic)++instance ToJSON HighWaterMark++instance FromJSON HighWaterMark++data DeterminismInputs = DeterminismInputs+  { clock :: Text,+    randomness :: Text,+    externalResponsesHash :: Text,+    failureScheduleHash :: Text+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON DeterminismInputs++instance FromJSON DeterminismInputs++-- | An observation is deliberately semantic. Artifact hashes may be included+-- as values, but they do not replace the durable state, continuation, or+-- identity coordinates which establish equivalence.+data Observation = Observation+  { durableState :: Map Text Value,+    continuations :: [Value],+    durableIdentities :: Map Text Text,+    freshAllocations :: [Text]+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON Observation++instance FromJSON Observation++data EvidenceVerdict+  = Passed+  | Failed Text+  | Unverified Text+  deriving stock (Eq, Show)++instance ToJSON EvidenceVerdict where+  toJSON = \case+    Passed -> Aeson.object ["status" Aeson..= ("passed" :: Text)]+    Failed reason -> Aeson.object ["status" Aeson..= ("failed" :: Text), "reason" Aeson..= reason]+    Unverified reason -> Aeson.object ["status" Aeson..= ("unverified" :: Text), "reason" Aeson..= reason]++instance FromJSON EvidenceVerdict where+  parseJSON = Aeson.withObject "EvidenceVerdict" $ \object -> do+    status <- object Aeson..: "status"+    case status :: Text of+      "passed" -> pure Passed+      "failed" -> Failed <$> object Aeson..: "reason"+      "unverified" -> Unverified <$> object Aeson..: "reason"+      other -> fail ("unsupported evidence verdict: " <> Text.unpack other)++data CaseResult = CaseResult+  { requiredCase :: RequiredCase,+    verdict :: EvidenceVerdict,+    observation :: Maybe Observation+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON CaseResult++instance FromJSON CaseResult++data CaptureReport = CaptureReport+  { reportVersion :: Text,+    role :: CaptureRole,+    buildPair :: BuildPair,+    inventoryId :: Text,+    corpusHash :: Text,+    observationContractVersion :: Text,+    highWaterMarks :: [HighWaterMark],+    selectedSurfaces :: [PersistedSurface],+    determinismInputs :: DeterminismInputs,+    results :: [CaseResult]+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON CaptureReport++instance FromJSON CaptureReport++data CompatibilityFailure+  = UnsupportedInventoryVersion Text+  | UnsupportedReportVersion CaptureRole Text+  | WrongCaptureRole CaptureRole CaptureRole+  | BuildPairMismatch Text+  | InventoryIdentityMismatch CaptureRole+  | CorpusIdentityMismatch+  | ObservationContractMismatch+  | DeterminismInputMismatch+  | MissingInventorySource InventorySource+  | DuplicateInventorySource InventorySource+  | InvalidInventoryContribution InventorySource Text+  | ConflictingRequiredCase Text+  | MissingRequiredCase CaptureRole Text+  | DuplicateCaseResult CaptureRole Text+  | CaseDefinitionMismatch CaptureRole Text+  | RequiredCaseFailed CaptureRole Text Text+  | RequiredCaseUnverified CaptureRole Text Text+  | EmptyPassedObservation CaptureRole Text+  | ObservationMismatch Text+  | MissingSelectedSurface CaptureRole PersistedSurface+  | EmptyHighWaterMarks CaptureRole+  | DuplicateHighWaterMark CaptureRole Text+  | HighWaterMarkMismatch+  deriving stock (Eq, Show)++-- | Failures for a codec whose decoder intentionally admits non-canonical wire+-- forms. The law covers normalization, the whole domain round trip, and replay+-- of the raw historical chain versus its canonical replacement.+data NormalizationFailure+  = NonCanonicalDecodeFailed Text+  | CanonicalEncodingMismatch+  | CanonicalDecodeFailed Text+  | DomainRoundTripFailed+  | NonCanonicalReplayFailed Text+  | CanonicalReplayFailed Text+  | NormalizedReplayDiverged+  deriving stock (Eq, Show)++-- | Check the shared normalization law for one non-canonical wire value.+--+-- The supplied replay function receives raw wire values, so a generated harness+-- can exercise its real parser and transducer rather than proving equality only+-- after both inputs have already been normalized.+checkNormalizationLaw ::+  (Eq wire, Eq domain, Eq observation) =>+  (wire -> Either Text domain) ->+  (domain -> wire) ->+  ([wire] -> Either Text observation) ->+  [wire] ->+  wire ->+  wire ->+  [wire] ->+  [NormalizationFailure]+checkNormalizationLaw decode encode replay prefix nonCanonical canonical suffix =+  case decode nonCanonical of+    Left problem -> [NonCanonicalDecodeFailed problem]+    Right decoded ->+      [CanonicalEncodingMismatch | encode decoded /= canonical]+        <> case decode canonical of+          Left problem -> [CanonicalDecodeFailed problem]+          Right canonicalDomain ->+            [DomainRoundTripFailed | canonicalDomain /= decoded || decode (encode decoded) /= Right decoded]+              <> replayFailures+  where+    replayFailures = case (replay (prefix <> [nonCanonical] <> suffix), replay (prefix <> [canonical] <> suffix)) of+      (Left problem, _) -> [NonCanonicalReplayFailed problem]+      (_, Left problem) -> [CanonicalReplayFailed problem]+      (Right historical, Right normalized) -> [NormalizedReplayDiverged | historical /= normalized]++-- | Union the independently supplied inventory contributions. Identical cases+-- may be required by more than one source. Conflicting definitions are reported+-- by 'validateCompatibility'.+requiredCases :: EvidenceInventory -> Map Text RequiredCase+requiredCases inventory =+  Map.fromList+    [ (required.caseId, required)+    | contribution <- inventory.contributions,+      required <- contribution.cases+    ]++validateCompatibility :: EvidenceInventory -> CaptureReport -> CaptureReport -> [CompatibilityFailure]+validateCompatibility inventory baselineReport candidateReport =+  concat+    [ inventoryFailures inventory,+      reportMetadataFailures inventory BaselineCapture baselineReport,+      reportMetadataFailures inventory CandidateCapture candidateReport,+      pairedMetadataFailures baselineReport candidateReport,+      reportCaseFailures inventory baselineReport,+      reportCaseFailures inventory candidateReport,+      observationFailures inventory baselineReport candidateReport+    ]++-- | Compare one baseline/candidate semantic observation outside the report+-- envelope. Runtime regression suites use this while constructing reports so+-- the same mismatch vocabulary covers aggregate, workflow, and process traces.+compareObservation :: Text -> Observation -> Observation -> [CompatibilityFailure]+compareObservation caseId baselineObservation candidateObservation =+  [ObservationMismatch caseId | baselineObservation /= candidateObservation]++releaseReady :: EvidenceInventory -> CaptureReport -> CaptureReport -> Bool+releaseReady inventory baselineReport candidateReport =+  null (validateCompatibility inventory baselineReport candidateReport)++inventoryFailures :: EvidenceInventory -> [CompatibilityFailure]+inventoryFailures inventory =+  versionFailure <> sourceFailures <> contributionFailures <> conflictFailures+  where+    versionFailure =+      [UnsupportedInventoryVersion inventory.inventoryVersion | inventory.inventoryVersion /= inventoryVersionV1]+    groupedSources = group (sort (map (.source) inventory.contributions))+    presentSources = Set.fromList (map (.source) inventory.contributions)+    sourceFailures =+      [MissingInventorySource source | source <- inventorySourcesV1, source `Set.notMember` presentSources]+        <> [DuplicateInventorySource source | source : remaining <- groupedSources, not (null remaining)]+    contributionFailures = concatMap validateContribution inventory.contributions+    byId =+      Map.fromListWith+        (++)+        [ (required.caseId, [required])+        | contribution <- inventory.contributions,+          required <- contribution.cases+        ]+    conflictFailures =+      [ ConflictingRequiredCase caseId+      | (caseId, definitions) <- Map.toList byId,+        Set.size (Set.fromList definitions) > 1+      ]++validateContribution :: InventoryContribution -> [CompatibilityFailure]+validateContribution contribution = case contribution.applicability of+  Applicable+    | null contribution.cases -> [InvalidInventoryContribution contribution.source "applicable source has no required cases"]+    | otherwise -> []+  NotApplicable reason+    | Text.null reason -> [InvalidInventoryContribution contribution.source "not-applicable source has no reason"]+    | not (null contribution.cases) -> [InvalidInventoryContribution contribution.source "not-applicable source supplies cases"]+    | otherwise -> []+  SourceUnverified reason ->+    [InvalidInventoryContribution contribution.source ("source is unverified: " <> reason)]++reportMetadataFailures :: EvidenceInventory -> CaptureRole -> CaptureReport -> [CompatibilityFailure]+reportMetadataFailures inventory expectedRole report =+  concat+    [ [UnsupportedReportVersion expectedRole report.reportVersion | report.reportVersion /= reportVersionV1],+      [WrongCaptureRole expectedRole report.role | report.role /= expectedRole],+      [BuildPairMismatch (captureRoleToken expectedRole) | report.buildPair /= inventory.buildPair],+      [InventoryIdentityMismatch expectedRole | report.inventoryId /= inventory.inventoryId],+      [EmptyHighWaterMarks expectedRole | null report.highWaterMarks],+      [DuplicateHighWaterMark expectedRole stream | stream <- duplicates (map (.stream) report.highWaterMarks)]+    ]++pairedMetadataFailures :: CaptureReport -> CaptureReport -> [CompatibilityFailure]+pairedMetadataFailures baselineReport candidateReport =+  concat+    [ [CorpusIdentityMismatch | baselineReport.corpusHash /= candidateReport.corpusHash],+      [ObservationContractMismatch | baselineReport.observationContractVersion /= candidateReport.observationContractVersion],+      [DeterminismInputMismatch | baselineReport.determinismInputs /= candidateReport.determinismInputs],+      [HighWaterMarkMismatch | Set.fromList baselineReport.highWaterMarks /= Set.fromList candidateReport.highWaterMarks]+    ]++reportCaseFailures :: EvidenceInventory -> CaptureReport -> [CompatibilityFailure]+reportCaseFailures inventory report =+  duplicateFailures <> concatMap checkRequired (Map.elems expected)+  where+    expected = requiredCases inventory+    role = report.role+    rowsById = Map.fromListWith (++) [(row.requiredCase.caseId, [row]) | row <- report.results]+    duplicateFailures = [DuplicateCaseResult role caseId | caseId <- duplicates (map (.requiredCase.caseId) report.results)]+    selected = Set.fromList report.selectedSurfaces+    checkRequired required = case Map.lookup required.caseId rowsById of+      Nothing -> [MissingRequiredCase role required.caseId]+      Just [] -> [MissingRequiredCase role required.caseId]+      Just (row : _) ->+        [CaseDefinitionMismatch role required.caseId | row.requiredCase /= required]+          <> [MissingSelectedSurface role required.surface | required.surface `Set.notMember` selected]+          <> verdictFailures role row++verdictFailures :: CaptureRole -> CaseResult -> [CompatibilityFailure]+verdictFailures role row = case row.verdict of+  Failed reason -> [RequiredCaseFailed role row.requiredCase.caseId reason]+  Unverified reason -> [RequiredCaseUnverified role row.requiredCase.caseId reason]+  Passed ->+    [ EmptyPassedObservation role row.requiredCase.caseId+    | maybe True observationIsEmpty row.observation+    ]++observationFailures :: EvidenceInventory -> CaptureReport -> CaptureReport -> [CompatibilityFailure]+observationFailures inventory baselineReport candidateReport =+  [ ObservationMismatch caseId+  | caseId <- Map.keys (requiredCases inventory),+    passedObservation caseId baselineReport /= passedObservation caseId candidateReport+  ]++passedObservation :: Text -> CaptureReport -> Maybe Observation+passedObservation caseId report = do+  row <- Map.lookup caseId (Map.fromList [(result.requiredCase.caseId, result) | result <- report.results])+  case row.verdict of+    Passed -> row.observation+    Failed _ -> Nothing+    Unverified _ -> Nothing++observationIsEmpty :: Observation -> Bool+observationIsEmpty observation =+  Map.null observation.durableState+    && null observation.continuations+    && Map.null observation.durableIdentities++duplicates :: (Ord a) => [a] -> [a]+duplicates values = [value | value : remaining <- group (sort values), not (null remaining)]++parseToken :: String -> [(Text, a)] -> Text -> Parser a+parseToken label tokens token =+  case lookup token tokens of+    Just value -> pure value+    Nothing -> fail ("unsupported " <> label <> ": " <> Text.unpack token)++renderCompatibilityFailure :: CompatibilityFailure -> Text+renderCompatibilityFailure = \case+  UnsupportedInventoryVersion version -> "unsupported inventory version: " <> version+  UnsupportedReportVersion role version -> captureRoleToken role <> " report has unsupported version: " <> version+  WrongCaptureRole expected actual -> "expected " <> captureRoleToken expected <> " capture, got " <> captureRoleToken actual+  BuildPairMismatch role -> role <> " report is not bound to the inventory build pair"+  InventoryIdentityMismatch role -> captureRoleToken role <> " report names a different inventory"+  CorpusIdentityMismatch -> "baseline and candidate corpus hashes differ"+  ObservationContractMismatch -> "baseline and candidate observation contracts differ"+  DeterminismInputMismatch -> "baseline and candidate determinism inputs differ"+  MissingInventorySource source -> "inventory omits source: " <> inventorySourceToken source+  DuplicateInventorySource source -> "inventory repeats source: " <> inventorySourceToken source+  InvalidInventoryContribution source reason -> inventorySourceToken source <> ": " <> reason+  ConflictingRequiredCase caseId -> "inventory gives conflicting definitions for case: " <> caseId+  MissingRequiredCase role caseId -> captureRoleToken role <> " report omits required case: " <> caseId+  DuplicateCaseResult role caseId -> captureRoleToken role <> " report repeats case: " <> caseId+  CaseDefinitionMismatch role caseId -> captureRoleToken role <> " report changes required case definition: " <> caseId+  RequiredCaseFailed role caseId reason -> captureRoleToken role <> " case failed (" <> caseId <> "): " <> reason+  RequiredCaseUnverified role caseId reason -> captureRoleToken role <> " case is unverified (" <> caseId <> "): " <> reason+  EmptyPassedObservation role caseId -> captureRoleToken role <> " case passed with an empty observation: " <> caseId+  ObservationMismatch caseId -> "baseline and candidate observations differ for case: " <> caseId+  MissingSelectedSurface role surface -> captureRoleToken role <> " report omits selected surface: " <> surface.owner <> "/" <> surface.identity+  EmptyHighWaterMarks role -> captureRoleToken role <> " report has no stream high-water marks"+  DuplicateHighWaterMark role stream -> captureRoleToken role <> " report repeats stream high-water mark: " <> stream+  HighWaterMarkMismatch -> "baseline and candidate high-water marks differ"

@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Data.Aeson (Value (String))+import Data.Aeson qualified as Aeson+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Keiro.Test.ReplayCompatibility+import Test.Hspec++main :: IO ()+main = hspec do+  describe "Replay compatibility evidence" do+    it "accepts complete, build-bound, equal semantic observations" do+      releaseReady inventory baselineReport candidateReport `shouldBe` True++    it "round-trips the versioned JSON contracts" do+      Aeson.eitherDecode (Aeson.encode inventory) `shouldBe` Right inventory+      Aeson.eitherDecode (Aeson.encode baselineReport) `shouldBe` Right baselineReport++    it "rejects an empty report" do+      let empty = baselineReport {results = [], selectedSurfaces = []}+      validateCompatibility inventory empty candidateReport+        `shouldContain` [MissingRequiredCase BaselineCapture "orders/placed"]++    it "rejects unequal corpus identities" do+      let changed = candidateReport {corpusHash = "sha256:candidate-corpus"}+      validateCompatibility inventory baselineReport changed `shouldContain` [CorpusIdentityMismatch]++    it "rejects unverified required evidence" do+      let changed = candidateReport {results = [result {verdict = Unverified "random source cannot be pinned", observation = Nothing}]}+      validateCompatibility inventory baselineReport changed+        `shouldContain` [RequiredCaseUnverified CandidateCapture "orders/placed" "random source cannot be pinned"]++    it "rejects two empty observations" do+      let emptyObservation = Observation Map.empty [] Map.empty []+          old = baselineReport {results = [result {observation = Just emptyObservation}]}+          new = candidateReport {results = [result {observation = Just emptyObservation}]}+      validateCompatibility inventory old new+        `shouldContain` [EmptyPassedObservation BaselineCapture "orders/placed"]++    it "rejects an omitted old-only surface even when remaining rows pass" do+      let oldOnly = RequiredCase "orders/retired" HistoricalRead (PersistedSurface "aggregate-stream" "orders" "OrderRetired:v1")+          changedInventory =+            inventory+              { contributions =+                  map+                    ( \contribution ->+                        if contribution.source == BaselinePersistedSurfaces+                          then contribution {cases = contribution.cases <> [oldOnly]}+                          else contribution+                    )+                    inventory.contributions+              }+      validateCompatibility changedInventory baselineReport candidateReport+        `shouldContain` [MissingRequiredCase BaselineCapture "orders/retired"]++    it "rejects direct-ID, transition, process, and Hole omissions independently of mapped consequences" do+      let omittedCases =+            [ (AggregateReplayImpacts, RequiredCase "orders/direct-id" SemanticEquivalence (PersistedSurface "direct-nominal" "orders" "OrderId")),+              (AggregateReplayImpacts, RequiredCase "orders/transition" SemanticEquivalence (PersistedSurface "transition" "orders" "PlaceOrder")),+              (CheckedProcessReactions, RequiredCase "billing/process" ProcessManagerReplay (PersistedSurface "process-reaction" "billing" "InvoiceAccepted")),+              (ApplicationOwnedObligations, RequiredCase "orders/hole" SemanticEquivalence (PersistedSurface "application-hole" "orders" "PlaceOrder/Hole"))+            ]+          changedInventory = inventory {contributions = map (addCases omittedCases) inventory.contributions}+          failures = validateCompatibility changedInventory baselineReport candidateReport+      failures `shouldContain` [MissingRequiredCase BaselineCapture "orders/direct-id"]+      failures `shouldContain` [MissingRequiredCase CandidateCapture "orders/transition"]+      failures `shouldContain` [MissingRequiredCase CandidateCapture "billing/process"]+      failures `shouldContain` [MissingRequiredCase CandidateCapture "orders/hole"]++    it "rejects an unchanged-name application source as unverified" do+      let changedInventory =+            inventory+              { contributions =+                  map+                    ( \contribution ->+                        if contribution.source == ApplicationOwnedObligations+                          then contribution {applicability = SourceUnverified "Hole source hash changed without a capture"}+                          else contribution+                    )+                    inventory.contributions+              }+      validateCompatibility changedInventory baselineReport candidateReport+        `shouldContain` [ InvalidInventoryContribution+                            ApplicationOwnedObligations+                            "source is unverified: Hole source hash changed without a capture"+                        ]++  describe "Normalization law" do+    it "accepts a non-canonical spelling only when it normalizes before replay" do+      checkNormalizationLaw decodeDecimal show replaySum ["2"] "01" "1" ["3"] `shouldBe` []++    it "rejects a decoder that preserves non-canonical information" do+      let lossyDecode "01" = Right (10 :: Int)+          lossyDecode value = decodeDecimal value+      checkNormalizationLaw lossyDecode show replaySum [] "01" "1" []+        `shouldContain` [CanonicalEncodingMismatch]++addCases :: [(InventorySource, RequiredCase)] -> InventoryContribution -> InventoryContribution+addCases additions contribution =+  contribution+    { applicability = if null selected then contribution.applicability else Applicable,+      cases = contribution.cases <> selected+    }+  where+    selected = [addedCase | (source, addedCase) <- additions, source == contribution.source]++buildPair :: BuildPair+buildPair =+  BuildPair+    { baseline = BuildIdentity "baseline-revision" "language-v5" "runtime-v1" "sha256:baseline-plan",+      candidate = BuildIdentity "candidate-revision" "language-v6" "runtime-v1" "sha256:candidate-plan"+    }++fixtureSurface :: PersistedSurface+fixtureSurface = PersistedSurface "aggregate-stream" "orders" "OrderPlaced:v1"++required :: RequiredCase+required = RequiredCase "orders/placed" SemanticEquivalence fixtureSurface++inventory :: EvidenceInventory+inventory =+  EvidenceInventory+    { inventoryVersion = inventoryVersionV1,+      inventoryId = "sha256:inventory",+      buildPair = Main.buildPair,+      contributions =+        [ InventoryContribution+            { source,+              applicability = if source == BaselinePersistedSurfaces then Applicable else NotApplicable "fixture has no obligations from this source",+              cases = if source == BaselinePersistedSurfaces then [required] else []+            }+        | source <- inventorySourcesV1+        ]+    }++fixtureObservation :: Observation+fixtureObservation =+  Observation+    { durableState = Map.fromList [("status", String "placed")],+      continuations = [String "ReserveInventory"],+      durableIdentities = Map.fromList [("event", "event_01")],+      freshAllocations = ["trace-id"]+    }++result :: CaseResult+result = CaseResult required Passed (Just fixtureObservation)++report :: CaptureRole -> CaptureReport+report role =+  CaptureReport+    { reportVersion = reportVersionV1,+      role,+      buildPair = Main.buildPair,+      inventoryId = "sha256:inventory",+      corpusHash = "sha256:corpus",+      observationContractVersion = "orders-observation/v1",+      highWaterMarks = [HighWaterMark "orders-1" 42],+      selectedSurfaces = [fixtureSurface],+      determinismInputs = DeterminismInputs "2026-09-19T00:00:00Z" "seed:v1" "sha256:responses" "sha256:schedule",+      results = [result]+    }++baselineReport :: CaptureReport+baselineReport = report BaselineCapture++candidateReport :: CaptureReport+candidateReport = report CandidateCapture++decodeDecimal :: String -> Either Text Int+decodeDecimal value = case reads value of+  [(number, "")] -> Right number+  _ -> Left "invalid decimal"++replaySum :: [String] -> Either Text Int+replaySum = fmap sum . traverse decodeDecimal