diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,100 @@ ## [Unreleased] -_No unreleased changes._ +## 0.4.0.1 — 2026-07-28 + +### Other Changes + +- Adds PVP upper bounds to every dependency that previously carried a lower + bound only, so `cabal check` reports no packaging warnings. No API or + behaviour change from 0.4.0.0, which was tagged but never published. + + +## 0.4.0.0 — 2026-07-28 + +### New Features + +- Structural scaffolding now creates hand-owned binding/fixture/initial + skeletons grouped by their declared owner modules, persists granular hole + obligations for non-overwriting re-scaffold reports, derives `Generic` for + private shape types, and provides `check --explain-bindings` for deterministic + package/module/signature/use-site reports. + +- Adds `Keiro.Dsl.CodecCompare`, a historical-codec comparison engine that + classifies RFC 8785 canonical-JSON parity between a declared codec and a + historical one, reports structured migration differences and declared-versus- + observed branch coverage gaps, and writes stable reports atomically. + `scaffold --codec-comparison MAPPED-NAME --comparison-out FILE` emits a + non-production comparison module and runner for one structural mapped type. + +- Adds `Keiro.Dsl.Coverage` and reporting-only `--coverage-report FILE` on both + `check` and `diff`, recording structural and opaque mapped-root coverage as + JSON. `check --fail-on-opaque` fails when a private persisted root still + contains an opaque boundary; `diff --fail-on-opaque-increase` fails when a + change adds a named opaque boundary. Without the flags, coverage is purely + informational. + +- Adds checked `mapped structural` and `mapped opaque` declarations with a + resolved, total type-expression graph. Validation rejects recursive, + ambiguous, non-injective, or incomplete mappings; recursive diff findings + carry six-surface compatibility vectors and complete command/event/register + use-site paths. + +- Structural consumer-type scaffolding now emits private + `Generated..Structural.Shape.*` wire representations, generates + structural codecs from declared keys/defaults/tags, delegates opaque values + only at their declared JSON boundary, imports consumer types into aggregate + domains, and exposes eligible total scalar getters through a narrow Keiki + 0.4 `StructuralProjections` witness facade. +- Scaffold preflight now reports consumer packages/modules, refuses consumer + modules inside the generated namespace before writing, includes consumer + requirements in manifests, persists canonical structural/opaque mapping + identities as forward-compatible JSON rows, and reports mapping drift on + subsequent runs. Mapped register wire/binding/initial identities now + participate in the aggregate fold fingerprint. +- Generated harnesses exercise both structural binding laws, declared codec + policy and current payload goldens, enum/union/optional fixture coverage, + canonical projection witness agreement, and forward-versus-replay equality + over every mapped and scalar register. The committed structural conformance + suite includes opaque-boundary checks and three falsifying mutations. +- `Keiro.Dsl.ReplayImpact` and `diff --replay-impact-out FILE`. Diffs now + print whether stored-data replay is unchanged and can emit a stable JSON + affected set for targeted auditing. New aggregates, events, transitions, + and syntactically proven guard loosenings are replay-neutral; changed + decode/fold surfaces identify conservative event types and whether + snapshot-bearing streams must be included. +- Scaffolding now emits one context-wide + `Generated..ReplayAudit` module. Its typed target list includes + every aggregate, validates discovered stream names against the generated + category, and documents the replay-neutral/targeted/full deployment tiers. +- `diff` now emits non-breaking, coded advisories when a router resolve or + dispatch surface, process handle surface, or unversioned process-timer + payload changes. The advisories explain the subscription drain and + dead-letter procedure needed to avoid mixed old/new deterministic fan-out + during a deployment. + +- First-class replay-only transitions for guard evolution (plan 143). A + `replay-only` prefix on a transition line marks it as serving inversion + only: the parser accepts it, the pretty-printer round-trips it, and the + scaffolder lowers it to `B.replayOnly` (keiki's `ReplayOnly` edge mode) in + the transducer skeleton. New validator rules: `ReplayOnlyEmitsNothing` + (error — a replay-only transition with no emit can invert nothing) and + `ReplayOnlyCommandStillLive` (warning — no live sibling for the (source, + command) pair; the fuller procedure is event retirement). A deprecated + event may keep being emitted by a replay-only transition — replay-only + transitions are not the write path. +- `diff` computes the guard-tightening remedy (`AggGuardTightened` + advisory): on any live-transition guard change without a replay-only twin, + it prints a paste-ready `replay-only` twin whose guard is the removed + region `old ∧ ¬new`, negation eliminated inside the guard grammar by the + new total `Keiro.Dsl.Grammar.complementExpr` (De Morgan, comparison + flipping, `x == false` for bare boolean atoms). The twin carries the old + transition's writes/emits/goto and re-parses as-is; it is printed, never + auto-applied. +- `Keiro.Dsl.PrettyPrint.renderTransition` renders one transition in + concrete `.keiro` syntax (used by the advisory). +- Requires `keiki >=0.4 && <0.5`, including `EdgeMode` and the typed structural + projection contracts. ## 0.3.0.0 — 2026-07-14 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,31 +5,47 @@ module Main (main) where import Control.Monad (when) +import Data.Aeson qualified as Aeson import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO -import Keiro.Dsl.Diff (Change (..), ChangeKind (..), diffSpecs, isBreaking) +import Keiro.Dsl.Coverage qualified as Coverage +import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSpecs, gateWith, gatedBreaking) +import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding) +import Keiro.Dsl.ExplainBindings (bindingObligations, renderBindingObligations) +import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) import Keiro.Dsl.Grammar (Placement (..), Spec (..)) import Keiro.Dsl.Parser (parseSpec) import Keiro.Dsl.PrettyPrint (renderSpec) -import Keiro.Dsl.Scaffold (Context (..)) -import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffold, renderRefusals, renderScaffoldReport) +import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpact) +import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule) +import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec) import Options.Applicative -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode (..), exitFailure) -import System.FilePath (makeRelative, takeDirectory) +import System.FilePath (makeRelative, normalise, takeDirectory, ()) import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode) data Command = Parse FilePath - | Check FilePath Bool - | Scaffold FilePath FilePath (Maybe String) Bool Bool - | Diff FilePath String + | Check FilePath Bool Bool (Maybe CheckCoverageOptions) + | Scaffold FilePath FilePath (Maybe String) Bool Bool (Maybe FilePath) (Maybe (String, FilePath)) + | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions) | New String +data CheckCoverageOptions = CheckCoverageOptions + { checkCoveragePath :: !FilePath + , checkFailOnOpaque :: !Bool + } + +data DiffCoverageOptions = DiffCoverageOptions + { diffCoveragePath :: !FilePath + , diffFailOnOpaqueIncrease :: !Bool + } + main :: IO () main = run =<< execParser opts where @@ -46,13 +62,13 @@ (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back")) <> command "check" - (info (Check <$> fileArg <*> emitSwitch <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error")) + (info (Check <$> fileArg <*> emitSwitch <*> explainBindingsSwitch <*> checkCoverageOptions <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error")) <> command "scaffold" - (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file")) + (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file")) <> command "diff" - (info (Diff <$> fileArg <*> sinceOpt <**> helper) (progDesc "Classify spec changes since a git ref as ADDITIVE/WARNING/BREAKING over the decode and identity surface; exit non-zero on any BREAKING change")) + (info (Diff <$> fileArg <*> sinceOpt <*> optional emitGoldensOpt <*> optional replayImpactOutOpt <*> many gateOpt <*> explainSwitch <*> optional reportOutOpt <*> diffCoverageOptions <**> helper) (progDesc "Classify spec changes since a git ref as per-surface compatibility vectors; exit non-zero on any gated BREAKING surface")) <> command "new" (info (New <$> kindArg <**> helper) (progDesc "Print a minimal valid .keiro skeleton for a node kind (aggregate, process, router, contract, intake, emit, publisher, workqueue, dispatch, workflow, operation)")) @@ -70,9 +86,57 @@ forceGeneratedOverwriteSwitch :: Parser Bool forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner") +goldensOpt :: Parser FilePath +goldensOpt = strOption (long "goldens" <> metavar "DIR" <> help "Golden-payload root to embed in generated aggregate harnesses") + +codecComparisonOpts :: Parser (Maybe (String, FilePath)) +codecComparisonOpts = + optional + ( (,) + <$> strOption (long "codec-comparison" <> metavar "MAPPED-NAME" <> help "Emit a non-production historical-codec comparison module for one structural mapped type (requires --comparison-out)") + <*> strOption (long "comparison-out" <> metavar "FILE" <> help "Exact generated comparison-module path under --out (requires --codec-comparison)") + ) + +emitGoldensOpt :: Parser FilePath +emitGoldensOpt = strOption (long "emit-goldens" <> metavar "DIR" <> help "Write old-shape payload fixtures for event version bumps without overwriting existing files") + +replayImpactOutOpt :: Parser FilePath +replayImpactOutOpt = strOption (long "replay-impact-out" <> metavar "FILE" <> help "Write the replay-neutral or affected audit input as JSON") + +gateOpt :: Parser CompatibilitySurface +gateOpt = option (eitherReader parseSurfaceName) (long "gate" <> metavar "SURFACE" <> help "Also fail on a breaking verdict for this compatibility surface (repeatable)") + +explainSwitch :: Parser Bool +explainSwitch = switch (long "explain" <> help "Print containing paths, failing directions, and remediation choices") + +reportOutOpt :: Parser FilePath +reportOutOpt = strOption (long "report-out" <> metavar "FILE" <> help "Write the full keiro-dsl/diff-report/1 compatibility report as JSON") + +coverageReportOpt :: Parser FilePath +coverageReportOpt = strOption (long "coverage-report" <> metavar "FILE" <> help "Write reporting-only structural/opaque mapped-root coverage as JSON") + +checkCoverageOptions :: Parser (Maybe CheckCoverageOptions) +checkCoverageOptions = + optional + ( CheckCoverageOptions + <$> coverageReportOpt + <*> switch (long "fail-on-opaque" <> help "Fail when a private persisted root contains an opaque boundary (requires --coverage-report)") + ) + +diffCoverageOptions :: Parser (Maybe DiffCoverageOptions) +diffCoverageOptions = + optional + ( DiffCoverageOptions + <$> coverageReportOpt + <*> switch (long "fail-on-opaque-increase" <> help "Fail when diff adds a named opaque boundary (requires --coverage-report)") + ) + emitSwitch :: Parser Bool emitSwitch = switch (long "emit" <> help "On success, pretty-print the parsed spec to stdout (folds parse + check into one call)") +explainBindingsSwitch :: Parser Bool +explainBindingsSwitch = switch (long "explain-bindings" <> help "On success, list the consumer-owned binding, fixture, and register-initial symbols required by structural mapped types") + sinceOpt :: Parser String sinceOpt = strOption (long "since" <> metavar "GIT-REF" <> help "Git ref to diff the spec against (e.g. HEAD, a tag, a branch)") @@ -90,7 +154,7 @@ hPutStrLn stderr (T.unpack err) exitFailure Right spec -> TIO.putStrLn (renderSpec spec) -run (Check fp emit) = do +run (Check fp emit explainBindings coverageOptions) = do input <- TIO.readFile fp case parseSpec fp input of Left err -> do @@ -101,11 +165,19 @@ mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags if any ((== Error) . severity) diags then exitFailure - else - if emit - then TIO.putStrLn (renderSpec spec) - else putStrLn "OK" -run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite) = do + else do + when emit (TIO.putStrLn (renderSpec spec)) + if explainBindings + then case bindingObligations spec of + Left graphErrors -> do + hPutStrLn stderr ("validated spec did not resolve its mapped type graph: " <> show graphErrors) + exitFailure + Right obligations -> TIO.putStrLn (renderBindingObligations (specContext spec) obligations) + else pure () + coverageOk <- runCheckCoverage fp spec coverageOptions + when (coverageOk && not emit && not explainBindings) (putStrLn "OK") + when (not coverageOk) exitFailure +run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do input <- TIO.readFile fp case parseSpec fp input of Left err -> do @@ -118,22 +190,31 @@ mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags when (any ((== Error) . severity) diags) exitFailure let ctx = mkContext cliRoot cliCollocate spec - case planScaffold ctx spec of - Left refusals -> do + goldenRoot = fromMaybe (takeDirectory fp "golden-payloads") cliGoldens + goldens <- loadGoldenPayloads goldenRoot spec + case (planScaffoldWithGoldens goldens ctx spec, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of + (Left refusals, _) -> do mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) exitFailure - Right modules -> do - result <- executeScaffold out forceGeneratedOverwrite fp ctx spec modules - case result of - Left refusals -> do - mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) - exitFailure - Right report -> mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report) + (_, Left comparisonError) -> TIO.hPutStrLn stderr comparisonError >> exitFailure + (Right modules, Right comparisonModule) -> do + comparisonReady <- preflightComparison out comparisonRequest comparisonModule + case comparisonReady of + Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure + Right () -> do + result <- executeScaffold out forceGeneratedOverwrite fp ctx spec modules + case result of + Left refusals -> do + mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) + exitFailure + Right report -> do + mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report) + writeComparison comparisonRequest comparisonModule run (New kind) = case skeletonFor (T.pack kind) of Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure Right skel -> TIO.putStr skel -run (Diff fp ref) = do +run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions) = do -- Resolve the spec to a repo-relative path so `git show :` works. let dir = takeDirectory fp rootRes <- git dir ["rev-parse", "--show-toplevel"] @@ -151,18 +232,24 @@ case (,) <$> parseSpec (ref <> ":" <> relPath) (T.pack oldText) <*> parseSpec fp newText of Left perr -> hPutStrLn stderr (T.unpack perr) >> exitFailure Right (oldSpec, newSpec) -> do + written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot + mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written let changes = diffSpecs oldSpec newSpec - mapM_ (putStrLn . renderChange) changes - if any isBreaking changes then exitFailure else pure () + impact = replayImpact oldSpec newSpec + effectiveGate = gateWith gatedSurfaces + mapM_ (TIO.putStrLn . renderFinding) changes + when explain $ + mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) + TIO.putStrLn (renderReplayImpact impact) + mapM_ (`Aeson.encodeFile` impact) replayImpactOut + mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut + coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions + if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () -renderChange :: Change -> String -renderChange c = case c of - Additive k -> "ADDITIVE: " <> body k - Advisory k -> "WARNING: " <> body k <> codeSuffix k - Breaking k -> "BREAKING: " <> body k <> codeSuffix k - where - body k = T.unpack (ckNode k) <> " " <> T.unpack (ckFacet k) <> " " <> T.unpack (ckSubject k) <> ": " <> T.unpack (ckDetail k) - codeSuffix k = maybe "" (\dc -> " [" <> show dc <> "]") (ckCode k) +shouldExplain :: Change -> Bool +shouldExplain Additive{} = False +shouldExplain Advisory{} = True +shouldExplain Breaking{} = True -- | Run git in a directory, returning trimmed stdout or stderr. git :: FilePath -> [String] -> IO (Either String String) @@ -174,6 +261,70 @@ trim :: String -> String trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String)) + +preflightComparison :: FilePath -> Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO (Either T.Text ()) +preflightComparison _ Nothing Nothing = pure (Right ()) +preflightComparison out (Just (_, requestedPath)) (Just comparisonModule) = do + let expectedPath = normalise (out modulePath comparisonModule) + actualPath = normalise requestedPath + if actualPath /= expectedPath + then + pure + ( Left + ( "--comparison-out must match the generated module path under --out: expected " + <> T.pack expectedPath + ) + ) + else do + exists <- doesFileExist actualPath + if not exists + then pure (Right ()) + else do + existing <- TIO.readFile actualPath + pure + ( if codecComparisonBanner `elem` T.lines existing + then Right () + else Left ("refusing to overwrite non-comparison output: " <> T.pack actualPath) + ) +preflightComparison _ _ _ = pure (Left "internal error: incomplete codec-comparison option pair") + +writeComparison :: Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO () +writeComparison Nothing Nothing = pure () +writeComparison (Just (_, path)) (Just comparisonModule) = do + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path (moduleText comparisonModule) + TIO.hPutStrLn stderr ("comparison generated " <> T.pack path <> " (migration evidence only)") +writeComparison _ _ = hPutStrLn stderr "internal error: incomplete codec-comparison output" >> exitFailure + +runCheckCoverage :: FilePath -> Spec -> Maybe CheckCoverageOptions -> IO Bool +runCheckCoverage _ _ Nothing = pure True +runCheckCoverage specPath spec (Just options) = + case Coverage.coverageReport specPath spec of + Left graphErrors -> do + hPutStrLn stderr ("validated spec did not resolve its mapped type graph for coverage: " <> show graphErrors) + pure False + Right baseReport -> do + let report = if checkFailOnOpaque options then Coverage.failOnOpaque baseReport else baseReport + emitCoverageReport (checkCoveragePath options) report + +runDiffCoverage :: FilePath -> T.Text -> Spec -> Spec -> Maybe DiffCoverageOptions -> IO Bool +runDiffCoverage _ _ _ _ Nothing = pure True +runDiffCoverage specPath reference oldSpec newSpec (Just options) = + case Coverage.coverageDiffReport specPath reference oldSpec newSpec of + Left graphErrors -> do + hPutStrLn stderr ("diff specs did not resolve their mapped type graph for coverage: " <> show graphErrors) + pure False + Right baseReport -> do + let report = if diffFailOnOpaqueIncrease options then Coverage.failOnOpaqueIncrease baseReport else baseReport + emitCoverageReport (diffCoveragePath options) report + +emitCoverageReport :: FilePath -> Coverage.CoverageReport -> IO Bool +emitCoverageReport path report = do + mapM_ (TIO.hPutStrLn stderr . Coverage.renderCoverageFinding (Coverage.coverageSpec report)) (Coverage.coverageFindings report) + TIO.putStr (Coverage.renderCoverageSummary report) + Coverage.writeCoverageReport path report + putStrLn ("coverage report written to " <> path) + pure (Coverage.coverageSucceeded report) {- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a 'Context'. Precedence is CLI flag > spec clause > built-in default. diff --git a/bench/structural-codec/Main.hs b/bench/structural-codec/Main.hs new file mode 100644 --- /dev/null +++ b/bench/structural-codec/Main.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main (main) where + +import Conformance.Structural.Bindings qualified as Bindings +import Conformance.Structural.Domain qualified as Domain +import Control.DeepSeq (NFData) +import Control.Monad (unless, (>=>)) +import Data.Aeson (Value (..), object, withObject, (.!=), (.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser, parseEither) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text (Text) +import Data.Text qualified as Text +import Generated.StructuralConformance.ArtifactCatalog.Codec (decodeArtifactInfoMapped, encodeArtifactInfoMapped) +import Keiro.Codec.Structural (FixtureCases (..)) +import Test.Tasty.Bench (Benchmark, bcompareWithin, bench, bgroup, defaultMain, nf) + +main :: IO () +main = defaultMain benchmarks + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup + "encode" + [ comparison "encode-small-record" baselineEncodeArtifact encodeArtifactInfoMapped smallArtifact + , comparison "encode-nested-union" (map baselineEncodeArtifact) (map encodeArtifactInfoMapped) unionArtifacts + , comparison "encode-large-list" (map baselineEncodeArtifact) (map encodeArtifactInfoMapped) largeArtifacts + ] + , bgroup + "decode" + [ comparison "decode-small-record" baselineDecodeArtifact decodeArtifactInfoMapped smallEncoded + , comparison "decode-nested-union" baselineDecodeArtifacts generatedDecodeArtifacts unionEncoded + , comparison "decode-large-list" baselineDecodeArtifacts generatedDecodeArtifacts largeEncoded + ] + ] + +comparison :: (NFData result) => String -> (input -> result) -> (input -> result) -> input -> Benchmark +comparison label baseline generated input = + bgroup + label + [ bench ("baseline-" <> label) (nf baseline input) + , bcompareWithin 0 2 ("baseline-" <> label) $ bench ("generated-" <> label) (nf generated input) + ] + +allArtifacts :: [Domain.ArtifactInfo] +allArtifacts = map snd (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)) + +smallArtifact :: Domain.ArtifactInfo +smallArtifact = snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)) + +unionArtifacts :: [Domain.ArtifactInfo] +unionArtifacts = allArtifacts + +largeArtifacts :: [Domain.ArtifactInfo] +largeArtifacts = take 2000 (cycle allArtifacts) + +smallEncoded :: Value +smallEncoded = encodeArtifactInfoMapped smallArtifact + +unionEncoded :: Value +unionEncoded = Aeson.toJSON (map encodeArtifactInfoMapped unionArtifacts) + +largeEncoded :: Value +largeEncoded = Aeson.toJSON (map encodeArtifactInfoMapped largeArtifacts) + +generatedDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo] +generatedDecodeArtifacts value = do + values <- firstText (parseEither Aeson.parseJSON value) + traverse decodeArtifactInfoMapped values + +baselineDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo] +baselineDecodeArtifacts = firstText . parseEither (Aeson.parseJSON >=> traverse baselineParseArtifact) + +baselineDecodeArtifact :: Value -> Either Text Domain.ArtifactInfo +baselineDecodeArtifact = firstText . parseEither baselineParseArtifact + +firstText :: Either String value -> Either Text value +firstText = either (Left . Text.pack) Right + +baselineEncodeArtifact :: Domain.ArtifactInfo -> Value +baselineEncodeArtifact value = + object + [ "artifact_key" .= value.artifactKey + , "display_name" .= value.displayName + , "artifact_hash" .= value.artifactHash + , "artifact_kind" .= encodeKind value.artifactKind + , "location" .= encodeLocation value.location + , "metadata" .= object ["note" .= value.metadata.note] + , "active" .= value.active + , "tags" .= value.tags + ] + +baselineParseArtifact :: Value -> Parser Domain.ArtifactInfo +baselineParseArtifact = withObject "ArtifactInfo" $ \value -> do + rejectUnknownFields "ArtifactInfo" ["artifact_key", "display_name", "artifact_hash", "artifact_kind", "location", "metadata", "active", "tags"] value + Domain.ArtifactInfo + <$> value .: "artifact_key" + <*> value .: "display_name" + <*> value .:? "artifact_hash" + <*> (value .:? "artifact_kind" .!= String "guide" >>= parseKind) + <*> (value .: "location" >>= parseLocation) + <*> (value .: "metadata" >>= withObject "ArtifactMetadata" (\metadata -> Domain.ArtifactMetadata <$> metadata .: "note")) + <*> (value .:? "active" .!= False) + <*> (value .:? "tags" .!= []) + +encodeKind :: Domain.ArtifactKind -> Value +encodeKind = \case + Domain.Guide -> String "guide" + Domain.Reference -> String "reference" + +parseKind :: Value -> Parser Domain.ArtifactKind +parseKind = \case + String "guide" -> pure Domain.Guide + String "reference" -> pure Domain.Reference + _ -> fail "unknown ArtifactKind" + +encodeLocation :: Domain.ArtifactLocation -> Value +encodeLocation = \case + Domain.LocalFile path -> tagged "local_file" (Just path) + Domain.LocalDir path -> tagged "local_dir" (Just path) + Domain.RepoPath path -> tagged "repo_path" (Just path) + Domain.LocUrl url -> tagged "url" (Just url) + Domain.Canonical -> tagged "canonical" Nothing + where + tagged :: Text -> Maybe Text -> Value + tagged tag contents = object (["tag" .= tag] <> maybe [] (pure . ("contents" .=)) contents) + +parseLocation :: Value -> Parser Domain.ArtifactLocation +parseLocation = withObject "ArtifactLocation" $ \value -> do + tag <- value .: "tag" :: Parser Text + case tag of + "local_file" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocalFile <$> value .: "contents") + "local_dir" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocalDir <$> value .: "contents") + "repo_path" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.RepoPath <$> value .: "contents") + "url" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocUrl <$> value .: "contents") + "canonical" -> rejectUnknownFields "ArtifactLocation" ["tag"] value >> pure Domain.Canonical + _ -> fail "unknown ArtifactLocation" + +rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser () +rejectUnknownFields label allowed value = + unless (null extras) (fail (label <> " contains unknown fields: " <> show extras)) + where + extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys value)) diff --git a/keiro-dsl.cabal b/keiro-dsl.cabal --- a/keiro-dsl.cabal +++ b/keiro-dsl.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-dsl -version: 0.3.0.0 +version: 0.4.0.1 synopsis: Typed specification toolchain for keiro services description: keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro @@ -18,11 +18,12 @@ extra-doc-files: CHANGELOG.md common warnings - ghc-options: -Wall + ghc-options: -Wall -Werror=missing-fields common shared default-language: GHC2024 default-extensions: + DuplicateRecordFields LambdaCase OverloadedStrings @@ -30,41 +31,54 @@ import: warnings, shared hs-source-dirs: src exposed-modules: + Keiro.Dsl.CodecCompare + Keiro.Dsl.Coverage Keiro.Dsl.Diff + Keiro.Dsl.DiffReport + Keiro.Dsl.ExplainBindings + Keiro.Dsl.FoldFingerprint + Keiro.Dsl.Goldens Keiro.Dsl.Grammar Keiro.Dsl.Harness Keiro.Dsl.Manifest + Keiro.Dsl.MappedConsumer + Keiro.Dsl.MappedDiff Keiro.Dsl.Parser Keiro.Dsl.PrettyPrint Keiro.Dsl.ReadModelShape + Keiro.Dsl.ReplayImpact Keiro.Dsl.Scaffold Keiro.Dsl.ScaffoldRecord Keiro.Dsl.ScaffoldRun Keiro.Dsl.Skeleton + Keiro.Dsl.TypeGraph Keiro.Dsl.Validate build-depends: - , base >=4.21 && <5 - , containers >=0.6 - , directory >=1.3 - , filepath >=1.4 - , megaparsec >=9.6 - , parser-combinators >=1.3 - , prettyprinter >=1.7 - , text >=2.1 + , aeson >=2.2.1 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , containers >=0.6 && <0.8 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , megaparsec >=9.6 && <9.9 + , parser-combinators >=1.3 && <1.4 + , prettyprinter >=1.7 && <1.8 + , text >=2.1 && <2.2 executable keiro-dsl import: warnings, shared hs-source-dirs: app main-is: Main.hs build-depends: + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , directory >=1.3 - , filepath >=1.4 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 , keiro-dsl - , optparse-applicative >=0.18 - , process >=1.6 - , text >=2.1 + , optparse-applicative >=0.18 && <0.20 + , process >=1.6 && <1.7 + , text >=2.1 && <2.2 test-suite keiro-dsl-test import: warnings, shared @@ -72,14 +86,17 @@ hs-source-dirs: test main-is: Main.hs build-depends: + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , containers >=0.6 - , directory >=1.3 - , filepath >=1.4 + , containers >=0.6 && <0.8 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 , hspec >=2.11 + , keiro-core , keiro-dsl + , process >=1.6 && <1.7 , QuickCheck >=2.14 - , text >=2.1 + , text >=2.1 && <2.2 -- Conformance: proves the scaffolded Generated modules plus a hand-filled -- Holes.hs compile against keiki/keiro and that the filled transducer passes @@ -92,6 +109,7 @@ hs-source-dirs: test/conformance main-is: Main.hs other-modules: + Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream @@ -100,12 +118,132 @@ HospitalCapacity.Reservation.Holes build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro - , text >=2.1 + , text >=2.1 && <2.2 +-- Plan 150 / IR-1: compiled structural consumer bindings, declared-wire +-- codecs, generated projection witnesses, opaque boundaries, fixture branch +-- coverage, current payload goldens, and mapped-register replay equality. +test-suite keiro-dsl-conformance-structural + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-structural + main-is: Main.hs + other-modules: + Conformance.Structural.Bindings + Conformance.Structural.Domain + Generated.StructuralConformance.ArtifactCatalog.Codec + Generated.StructuralConformance.ArtifactCatalog.Domain + Generated.StructuralConformance.ArtifactCatalog.EventStream + Generated.StructuralConformance.ArtifactCatalog.Harness + Generated.StructuralConformance.ArtifactCatalog.Projection + Generated.StructuralConformance.ReplayAudit + Generated.StructuralConformance.Structural.Shape.ArtifactInfo + Generated.StructuralConformance.Structural.Shape.ArtifactKind + Generated.StructuralConformance.Structural.Shape.ArtifactLocation + Generated.StructuralConformance.Structural.Shape.ArtifactMetadata + Generated.StructuralConformance.StructuralProjections + StructuralConformance.ArtifactCatalog.Holes + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , containers >=0.6 && <0.8 + , deepseq >=1.5 && <1.6 + , keiki >=0.4 && <0.5 + , keiro + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + +-- Plan 152 / Experiment B: a consumer-owned historical codec and finite JSON +-- corpus compared with the generated structural codec. The comparison module +-- is opt-in tooling output and is not part of the production scaffold record. +test-suite keiro-dsl-conformance-codec-compare + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: + test/conformance-codec-compare test/conformance-structural + + main-is: Main.hs + other-modules: + Conformance.CodecCompare.Historical + Conformance.Structural.Bindings + Conformance.Structural.Domain + Generated.StructuralConformance.ArtifactCatalog.Codec + Generated.StructuralConformance.ArtifactCatalog.Domain + Generated.StructuralConformance.Structural.CodecCompare.ArtifactInfo + Generated.StructuralConformance.Structural.Shape.ArtifactInfo + Generated.StructuralConformance.Structural.Shape.ArtifactKind + Generated.StructuralConformance.Structural.Shape.ArtifactLocation + Generated.StructuralConformance.Structural.Shape.ArtifactMetadata + + build-depends: + , aeson >=2.2.1 && <2.3 + , base >=4.21 && <5 + , containers >=0.6 && <0.8 + , deepseq >=1.5 && <1.6 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , keiki >=0.4 && <0.5 + , keiro + , keiro-dsl + , text >=2.1 && <2.2 + +-- Plan 147 M2: a dedicated honest-wire baseline plus a dormant idempotent +-- dishonest WireCtor used by replay-mutation-test.sh to prove that generated +-- forward/replay register comparisons catch state divergence missed by the +-- pre-existing validator, codec round-trip, and accept assertions. +test-suite keiro-dsl-conformance-replay + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-replay + main-is: Main.hs + other-modules: + Generated.ReplayDivergence.Note.Codec + Generated.ReplayDivergence.Note.Domain + Generated.ReplayDivergence.Note.EventStream + Generated.ReplayDivergence.Note.Harness + Generated.ReplayDivergence.Note.Projection + Generated.ReplayDivergence.ReplayAudit + ReplayDivergence.Note.Holes + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , keiki >=0.4 && <0.5 + , keiro + , text >=2.1 && <2.2 + +benchmark keiro-dsl-codec-bench + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: bench/structural-codec test/conformance-structural + main-is: Main.hs + other-modules: + Conformance.Structural.Bindings + Conformance.Structural.Domain + Generated.StructuralConformance.ArtifactCatalog.Codec + Generated.StructuralConformance.ArtifactCatalog.Domain + Generated.StructuralConformance.Structural.Shape.ArtifactInfo + Generated.StructuralConformance.Structural.Shape.ArtifactKind + Generated.StructuralConformance.Structural.Shape.ArtifactLocation + Generated.StructuralConformance.Structural.Shape.ArtifactMetadata + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , containers >=0.6 && <0.8 + , deepseq >=1.5 && <1.6 + , keiki >=0.4 && <0.5 + , keiro + , tasty-bench >=0.5 && <0.6 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + -- EP-109 M2: snapshot-enabled aggregate scaffolding compiled against the live -- defaultStateCodec and stream-construction guards, with the captured codec -- identity checked against keiki's regFileShapeHash. @@ -115,17 +253,18 @@ hs-source-dirs: test/conformance-snapshot main-is: Main.hs other-modules: + Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream HospitalCapacity.Reservation.Holes build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro - , text >=2.1 + , text >=2.1 && <2.2 -- EP-106 M6: every distinct `new ` skeleton is scaffolded into this -- committed tree. Compiling the union proves a starter that passes `check` @@ -136,6 +275,7 @@ hs-source-dirs: test/conformance-skeletons main-is: Main.hs other-modules: + SkelAggregate.Generated.MyService.ReplayAudit SkelAggregate.Generated.MyService.Thing.Codec SkelAggregate.Generated.MyService.Thing.Domain SkelAggregate.Generated.MyService.Thing.EventStream @@ -154,6 +294,7 @@ SkelProcess.Generated.MyService.Hospital.Projection SkelProcess.Generated.MyService.HospitalSurge.Process SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness + SkelProcess.Generated.MyService.ReplayAudit SkelProcess.Generated.MyService.Surge.Codec SkelProcess.Generated.MyService.Surge.Domain SkelProcess.Generated.MyService.Surge.EventStream @@ -166,6 +307,7 @@ SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelHarness SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable SkelQueue.Generated.MyService.Reservation_work.Queue + SkelQueue.Generated.MyService.Reservation_work.QueueCodec SkelQueue.Generated.MyService.Reservation_work.QueuePolicy SkelQueue.Generated.MyService.Transfer_decisions.ReadModel SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness @@ -179,23 +321,25 @@ SkelRouter.Generated.MyService.Page.Projection SkelRouter.Generated.MyService.PagingRouter.Router SkelRouter.Generated.MyService.PagingRouter.RouterHarness + SkelRouter.Generated.MyService.ReplayAudit SkelRouter.MyService.Page.Holes SkelRouter.MyService.PagingRouter.RouterHoles SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , containers , effectful-core , hasql-transaction - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro + , keiro-core , keiro-pgmq , kiroku-store , shibuya-core - , text >=2.1 + , text >=2.1 && <2.2 , time , uuid @@ -209,6 +353,7 @@ main-is: Main.hs other-modules: Billing.Subscription.Holes + Generated.Billing.ReplayAudit Generated.Billing.Subscription.Codec Generated.Billing.Subscription.Domain Generated.Billing.Subscription.EventStream @@ -216,11 +361,11 @@ Generated.Billing.Subscription.Projection build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro - , text >=2.1 + , text >=2.1 && <2.2 -- Contract codec conformance (EP-4): the scaffolded self-contained contract -- payload ADT + codec, compiled + round-tripped per event type. @@ -231,9 +376,9 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.Emergency.Contract build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , text >=2.1 + , text >=2.1 && <2.2 -- EP-4 intake runtime conformance: the scaffolded Inbox disposition + dedupe -- policy compiled against the LIVE Keiro.Inbox.Types (InboxResult / dedupe). @@ -285,11 +430,16 @@ type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-queue main-is: Main.hs - other-modules: Generated.HospitalCapacity.Reservation_work.Queue + other-modules: + Generated.HospitalCapacity.Reservation_work.Queue + Generated.HospitalCapacity.Reservation_work.QueueCodec + build-depends: - , aeson >=2.2 - , base >=4.21 && <5 - , text >=2.1 + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , keiro-core + , keiro-pgmq + , text >=2.1 && <2.2 -- EP-5 pgmq runtime conformance: the scaffolded QueuePolicy (RetryPolicy + -- JobOutcome disposition) compiled against the LIVE Keiro.PGMQ.Job runtime. @@ -300,16 +450,18 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.Reservation_work.Queue + Generated.HospitalCapacity.Reservation_work.QueueCodec Generated.HospitalCapacity.Reservation_work.QueuePolicy build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 + , keiro-core , keiro-dsl , keiro-pgmq , pgmq-config , pgmq-core - , text >=2.1 + , text >=2.1 && <2.2 -- EP-107 read-model runtime conformance: the scaffolded ReadModel record, -- registration/rebuild helpers, AsyncProjection, facts harness, and a filled @@ -331,7 +483,7 @@ , hasql-transaction , keiro , kiroku-store - , text >=2.1 + , text >=2.1 && <2.2 -- EP-5 M5 full-service conformance: a complete pgmq dispatch service — scaffolded -- Job codec + retry policy + a filled worker handler assembled into a live @@ -343,15 +495,17 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.Reservation_work.Queue + Generated.HospitalCapacity.Reservation_work.QueueCodec Generated.HospitalCapacity.Reservation_work.QueuePolicy HospitalCapacity.ReservationWork.WorkqueueJob build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , effectful-core + , keiro-core , keiro-pgmq - , text >=2.1 + , text >=2.1 && <2.2 -- Workflow facts harness (EP-6): the scaffolded self-contained WorkflowFacts -- module asserted against a hand-written expectation (mutation-pinnable). @@ -380,7 +534,7 @@ , base >=4.21 && <5 , containers , keiro - , text >=2.1 + , text >=2.1 && <2.2 -- EP-3 M5 full-service conformance: a complete process service — the scaffolded -- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a @@ -395,6 +549,7 @@ Generated.SurgeDemo.Hospital.Domain Generated.SurgeDemo.Hospital.EventStream Generated.SurgeDemo.Hospital.Projection + Generated.SurgeDemo.ReplayAudit Generated.SurgeDemo.Surge.Codec Generated.SurgeDemo.Surge.Domain Generated.SurgeDemo.Surge.EventStream @@ -405,14 +560,14 @@ SurgeDemo.SurgeFlow.Manager build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro , shibuya-core - , text >=2.1 - , time >=1.12 - , uuid >=1.3 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + , uuid >=1.3 && <1.4 -- EP-6 M5 full-service conformance: a complete durable workflow — scaffolded -- WorkflowRuntime + a filled ordered step/await body — compiled against the @@ -427,12 +582,12 @@ HospitalCapacity.HospitalTransferReservation.WorkflowBody build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , containers , effectful-core , keiro - , text >=2.1 + , text >=2.1 && <2.2 -- EP-3 process runtime conformance: the scaffolded Process module's -- deterministic wiring (timer-request builder + fire disposition) compiled @@ -444,14 +599,14 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.HospitalSurge.Process build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , keiro , keiro-dsl , shibuya-core - , text >=2.1 - , time >=1.12 - , uuid >=1.3 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + , uuid >=1.3 && <1.4 -- EP-108 router runtime conformance: generated policy lowering and the live -- target-keyed deterministic id contract. @@ -469,8 +624,8 @@ , keiro , kiroku-store , shibuya-core - , text >=2.1 - , uuid >=1.3 + , text >=2.1 && <2.2 + , uuid >=1.3 && <1.4 -- EP-108 generated router-facts harness with hand-written expectations. test-suite keiro-dsl-conformance-router @@ -494,17 +649,18 @@ Generated.IncidentPaging.Page.EventStream Generated.IncidentPaging.PagingRouter.Router Generated.IncidentPaging.PagingRouter.RouterHarness + Generated.IncidentPaging.ReplayAudit IncidentPaging.Page.Holes IncidentPaging.PagingRouter.RouterValue build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , effectful-core - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro , shibuya-core - , text >=2.1 + , text >=2.1 && <2.2 -- MP-15/EP-110 M6 cold-start: a fresh agent, given only the authoring skill -- and feature sentence, produced this aggregate + readmodel + router service. @@ -526,21 +682,22 @@ Generated.TransferRouting.Hospital_load.ReadModelTable Generated.TransferRouting.HospitalTransferRouter.Router Generated.TransferRouting.HospitalTransferRouter.RouterHarness + Generated.TransferRouting.ReplayAudit TransferRouting.Hospital.Holes TransferRouting.Hospital_load.ReadModelHoles TransferRouting.HospitalTransferRouter.RouterHoles TransferRouting.HospitalTransferRouter.RouterValue build-depends: - , aeson >=2.2 + , aeson >=2.2 && <2.3 , base >=4.21 && <5 , effectful-core , hasql-transaction - , keiki >=0.2 && <0.3 + , keiki >=0.4 && <0.5 , keiro , kiroku-store , shibuya-core - , text >=2.1 + , text >=2.1 && <2.2 -- Process-manager facts harness (EP-3 M4): the self-contained, firewall-clean -- ProcessHarness module scaffolded from hospital-surge.keiro, compiled + run to @@ -555,7 +712,7 @@ other-modules: Generated.HospitalCapacity.HospitalSurge.ProcessHarness build-depends: , base >=4.21 && <5 - , text >=2.1 + , text >=2.1 && <2.2 -- Conformance for the evolved (v2) Reservation aggregate: proves the scaffolded -- Codec schemaVersion=2 + upcasters wiring compiles and that the filled upcaster @@ -568,6 +725,7 @@ hs-source-dirs: test/conformance-v2 main-is: Main.hs other-modules: + Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream @@ -576,8 +734,9 @@ HospitalCapacity.Reservation.Holes build-depends: - , aeson >=2.2 - , base >=4.21 && <5 - , keiki >=0.2 && <0.3 + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , directory >=1.3 && <1.4 + , keiki >=0.4 && <0.5 , keiro - , text >=2.1 + , text >=2.1 && <2.2 diff --git a/src/Keiro/Dsl/CodecCompare.hs b/src/Keiro/Dsl/CodecCompare.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/CodecCompare.hs @@ -0,0 +1,742 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +{- | Pure historical-codec comparison and migration-evidence reports. + +The comparison is deliberately finite evidence over typed fixture cases and +historical JSON goldens. It never changes which codec owns the wire schema and +never upgrades an opaque declaration to a structural claim. +-} +module Keiro.Dsl.CodecCompare ( + FixtureOrigin (..), + DecodeOutcome (..), + JsonPointer (..), + ComparisonDifference (..), + HistoricalCodec (..), + CompareObservation (..), + FixtureVerdict (..), + CompareInputIssue (..), + BranchKind (..), + DeclaredBranch (..), + ObservedBranch (..), + CoverageGap (..), + BranchSchema (..), + BranchField (..), + BranchArm (..), + CompareProvenance (..), + ClassifiedObservation (..), + CompareReport (..), + ReportWriteError (..), + authorityStatement, + canonicalJsonBytes, + classifyObservation, + declaredBranchesFor, + observedBranchesFor, + compareReport, + renderCompareReport, + reportSucceeded, + writeCompareReportAtomic, +) where + +import Control.Exception (IOException, bracketOnError, displayException, try) +import Control.Monad (when) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, withText, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.RFC8785 qualified as RFC8785 +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Foldable (toList) +import Data.List (sort) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..)) +import Keiro.Dsl.Validate (DiagnosticCode (..)) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile) +import System.FilePath (takeDirectory, takeFileName) +import System.IO (Handle, hClose, openBinaryTempFile) + +data FixtureOrigin = HistoricalGolden | FromBinding + deriving stock (Eq, Ord, Show) + +data DecodeOutcome + = DecodedShape !Value + | DecodeFailed !Text + deriving stock (Eq, Show) + +newtype JsonPointer = JsonPointer {unJsonPointer :: Text} + deriving stock (Eq, Ord, Show) + +data ComparisonDifference + = EncodedValueDifference !JsonPointer !Value !Value + | DecodedValueDifference !JsonPointer !Value !Value + | GeneratedDecodeRejected !Text + deriving stock (Eq, Show) + +{- | A historical codec is an explicit value supplied by consumer-owned test +code. Its identity and version are report provenance, not dispatch keys. +-} +data HistoricalCodec a = HistoricalCodec + { hcIdentity :: !Text + , hcVersion :: !Text + , hcEncode :: !(a -> Value) + , hcDecode :: !(Value -> Either Text a) + } + +data CompareObservation + = EncodeObservation + { coCaseName :: !Text + , coHistoricalValue :: !Value + , coGeneratedValue :: !Value + } + | DecodeObservation + { coFixturePath :: !FilePath + , coInputValue :: !Value + , coHistoricalDecode :: !DecodeOutcome + , coGeneratedDecode :: !DecodeOutcome + } + deriving stock (Eq, Show) + +data FixtureVerdict + = JsonParity + | RequiresVersionWork !ComparisonDifference + deriving stock (Eq, Show) + +data CompareInputIssue + = HistoricalGoldenUnreadable !FilePath !Text + | HistoricalCodecRejected !FilePath !Text + | HistoricalCodecProvenanceInvalid !Text + deriving stock (Eq, Show) + +data BranchKind + = UnionArm !Text + | OptionalPresent + | OptionalMissing + | ExplicitNull + deriving stock (Eq, Ord, Show) + +data DeclaredBranch = DeclaredBranch + { dbOrigin :: !FixtureOrigin + , dbPointer :: !JsonPointer + , dbKind :: !BranchKind + } + deriving stock (Eq, Ord, Show) + +data ObservedBranch = ObservedBranch + { obOrigin :: !FixtureOrigin + , obPointer :: !JsonPointer + , obKind :: !BranchKind + } + deriving stock (Eq, Ord, Show) + +data CoverageGap = CoverageGap + { cgOrigin :: !FixtureOrigin + , cgPointer :: !JsonPointer + , cgKind :: !BranchKind + } + deriving stock (Eq, Ord, Show) + +{- | A codec-independent branch description embedded into generated +comparison runners. The generator constructs it through the checked type +graph's total algebras, so this module never has to interpret a consumer type. +-} +data BranchSchema + = BranchScalar + | BranchOptional !BranchSchema + | BranchList !BranchSchema + | BranchMap !BranchSchema + | BranchRecord ![BranchField] + | BranchUnion !Text !Text ![BranchArm] + deriving stock (Eq, Show) + +data BranchField = BranchField + { bfWireKey :: !Text + , bfPresenceOptional :: !Bool + , bfSchema :: !BranchSchema + } + deriving stock (Eq, Show) + +data BranchArm = BranchArm + { baWireTag :: !Text + , baPayloadSchema :: !(Maybe BranchSchema) + } + deriving stock (Eq, Show) + +data CompareProvenance = CompareProvenance + { cpHistoricalCodecIdentity :: !Text + , cpHistoricalCodecVersion :: !Text + , cpCanonicalType :: !CanonicalTypeId + , cpBindingSymbol :: !QualifiedValueName + , cpBindingVersion :: !BindingVersion + , cpWireFingerprint :: !Text + } + deriving stock (Eq, Show) + +data ClassifiedObservation = ClassifiedObservation + { classifiedOrigin :: !FixtureOrigin + , classifiedName :: !Text + , classifiedVerdict :: !FixtureVerdict + } + deriving stock (Eq, Show) + +data CompareReport = CompareReport + { crProvenance :: !CompareProvenance + , crObservations :: ![ClassifiedObservation] + , crInputIssues :: ![CompareInputIssue] + , crCoverageGaps :: ![CoverageGap] + , crAuthority :: !Text + } + deriving stock (Eq, Show) + +data ReportWriteError = ReportWriteError + { reportWritePath :: !FilePath + , reportWriteMessage :: !Text + } + deriving stock (Eq, Show) + +authorityStatement :: Text +authorityStatement = + "This comparison is MIGRATION EVIDENCE ONLY. After cutover the generated structural codec is the sole wire authority. This runner is never a runtime fallback and never upgrades an opaque declaration to structural. Resolve each difference with an explicit version bump and upcaster, or correct the declaration to match the historical wire contract; \"close enough\" is not an outcome." + +-- | Render a JSON value in RFC 8785 canonical form. +canonicalJsonBytes :: Value -> ByteString +canonicalJsonBytes = LazyByteString.toStrict . RFC8785.encodeCanonical + +classifyObservation :: CompareObservation -> Either CompareInputIssue FixtureVerdict +classifyObservation observation = case observation of + EncodeObservation _ historical generated -> + Right (classifyValues EncodedValueDifference historical generated) + DecodeObservation fixturePath _ historical generated -> case historical of + DecodeFailed reason -> Left (HistoricalCodecRejected fixturePath reason) + DecodedShape historicalValue -> case generated of + DecodeFailed reason -> Right (RequiresVersionWork (GeneratedDecodeRejected reason)) + DecodedShape generatedValue -> + Right (classifyValues DecodedValueDifference historicalValue generatedValue) + +classifyValues :: (JsonPointer -> Value -> Value -> ComparisonDifference) -> Value -> Value -> FixtureVerdict +classifyValues difference historical generated + | canonicalJsonBytes historical == canonicalJsonBytes generated = JsonParity + | otherwise = RequiresVersionWork (difference (firstDivergentPointer historical generated) historical generated) + +compareReport :: + CompareProvenance -> + [CompareInputIssue] -> + [CompareObservation] -> + [DeclaredBranch] -> + [ObservedBranch] -> + CompareReport +compareReport provenance suppliedIssues observations declaredBranches observedBranches = + CompareReport + { crProvenance = provenance + , crObservations = classified + , crInputIssues = provenanceIssues provenance <> suppliedIssues <> classificationIssues + , crCoverageGaps = coverageGaps declaredBranches observedBranches + , crAuthority = authorityStatement + } + where + outcomes = map classify observations + classified = [value | Right value <- outcomes] + classificationIssues = [issue | Left issue <- outcomes] + + classify observation = case classifyObservation observation of + Left issue -> Left issue + Right verdict -> + Right + ClassifiedObservation + { classifiedOrigin = observationOrigin observation + , classifiedName = observationName observation + , classifiedVerdict = verdict + } + +observationOrigin :: CompareObservation -> FixtureOrigin +observationOrigin EncodeObservation{} = FromBinding +observationOrigin DecodeObservation{} = HistoricalGolden + +observationName :: CompareObservation -> Text +observationName EncodeObservation{coCaseName = name} = name +observationName DecodeObservation{coFixturePath = path} = T.pack path + +provenanceIssues :: CompareProvenance -> [CompareInputIssue] +provenanceIssues provenance = + [ HistoricalCodecProvenanceInvalid "historical codec identity must not be blank" + | T.null (T.strip (cpHistoricalCodecIdentity provenance)) + ] + <> [ HistoricalCodecProvenanceInvalid "historical codec version must not be blank" + | T.null (T.strip (cpHistoricalCodecVersion provenance)) + ] + +coverageGaps :: [DeclaredBranch] -> [ObservedBranch] -> [CoverageGap] +coverageGaps declared observed = + [ CoverageGap (dbOrigin branch) (dbPointer branch) (dbKind branch) + | branch <- declared + , branchKey branch `Set.notMember` observedKeys + ] + where + observedKeys = Set.fromList (map observedBranchKey observed) + branchKey branch = (dbOrigin branch, dbPointer branch, dbKind branch) + observedBranchKey branch = (obOrigin branch, obPointer branch, obKind branch) + +declaredBranchesFor :: FixtureOrigin -> BranchSchema -> [DeclaredBranch] +declaredBranchesFor origin = Set.toAscList . go "" + where + declared pointer kind = Set.singleton (DeclaredBranch origin (JsonPointer pointer) kind) + go pointer schema = case schema of + BranchScalar -> Set.empty + BranchOptional nested -> + declared pointer OptionalPresent + <> declared pointer ExplicitNull + <> go pointer nested + BranchList nested -> go (appendPointer pointer "*") nested + BranchMap nested -> go (appendPointer pointer "*") nested + BranchRecord fields -> + Set.unions + [ presenceBranches pointer field <> go (appendPointer pointer (bfWireKey field)) (bfSchema field) + | field <- fields + ] + BranchUnion _tagField contentsField arms -> + Set.unions + [ declared pointer (UnionArm (baWireTag arm)) + <> maybe Set.empty (go (appendPointer pointer contentsField)) (baPayloadSchema arm) + | arm <- arms + ] + presenceBranches pointer field + | bfPresenceOptional field = + let fieldPointer = appendPointer pointer (bfWireKey field) + in case origin of + HistoricalGolden -> declared fieldPointer OptionalMissing <> declared fieldPointer OptionalPresent + FromBinding -> declared fieldPointer OptionalPresent + | otherwise = Set.empty + +observedBranchesFor :: FixtureOrigin -> BranchSchema -> Value -> [ObservedBranch] +observedBranchesFor origin schema = Set.toAscList . go "" schema + where + observed pointer kind = Set.singleton (ObservedBranch origin (JsonPointer pointer) kind) + go pointer branchSchema value = case branchSchema of + BranchScalar -> Set.empty + BranchOptional nested -> case value of + Null -> observed pointer ExplicitNull + _ -> observed pointer OptionalPresent <> go pointer nested value + BranchList nested -> case value of + Array values -> Set.unions [go (appendPointer pointer "*") nested item | item <- toList values] + _ -> Set.empty + BranchMap nested -> case value of + Object values -> Set.unions [go (appendPointer pointer "*") nested item | item <- KeyMap.elems values] + _ -> Set.empty + BranchRecord fields -> case value of + Object values -> Set.unions (map (observeField pointer values) fields) + _ -> Set.empty + BranchUnion tagField contentsField arms -> case value of + Object values -> case KeyMap.lookup (Key.fromText tagField) values of + Just (String tag) -> case filter ((== tag) . baWireTag) arms of + arm : _ -> + observed pointer (UnionArm tag) + <> case (baPayloadSchema arm, KeyMap.lookup (Key.fromText contentsField) values) of + (Just nested, Just payload) -> go (appendPointer pointer contentsField) nested payload + _ -> Set.empty + [] -> Set.empty + _ -> Set.empty + _ -> Set.empty + observeField pointer values field = + let fieldPointer = appendPointer pointer (bfWireKey field) + in case KeyMap.lookup (Key.fromText (bfWireKey field)) values of + Nothing + | bfPresenceOptional field -> observed fieldPointer OptionalMissing + | otherwise -> Set.empty + Just fieldValue -> + (if bfPresenceOptional field then observed fieldPointer OptionalPresent else Set.empty) + <> go fieldPointer (bfSchema field) fieldValue + +reportSucceeded :: CompareReport -> Bool +reportSucceeded report = + null (crInputIssues report) + && null (crCoverageGaps report) + && all ((== JsonParity) . classifiedVerdict) (crObservations report) + +renderCompareReport :: CompareReport -> Text +renderCompareReport report = + T.unlines + ( [ "codec comparison: " + <> unCanonicalTypeId (cpCanonicalType provenance) + <> " (binding-version \"" + <> unBindingVersion (cpBindingVersion provenance) + <> "\")" + , "historical codec: \"" + <> cpHistoricalCodecIdentity provenance + <> "\" version \"" + <> cpHistoricalCodecVersion provenance + <> "\"" + , "observations: " <> tshow (length observations) + , " encode parity: " <> ratio FromBinding + , " structural decode agreement: " <> ratio HistoricalGolden + , "requires explicit version/upcaster work: " <> tshow (length differences) <> " observations [" <> codeText CodecCompareDifference <> "]" + ] + <> concatMap renderDifference differences + <> [ "input issues: " <> tshow (length (crInputIssues report)) <> " [" <> codeText CodecCompareInvalidInput <> "]" + ] + <> map (" " <>) (map renderInputIssue (crInputIssues report)) + <> [ "coverage gaps: " <> tshow (length (crCoverageGaps report)) <> " [" <> codeText CodecCompareCoverageGap <> "]" + ] + <> map (" " <>) (map renderCoverageGap (crCoverageGaps report)) + <> [ if reportSucceeded report + then "result: PARITY" + else "result: NOT PARITY — " <> tshow (length differences) <> " differences" + , crAuthority report + ] + ) + where + provenance = crProvenance report + observations = crObservations report + differences = filter ((/= JsonParity) . classifiedVerdict) observations + ratio origin = + let matching = filter ((== origin) . classifiedOrigin) observations + parityCount = length (filter ((== JsonParity) . classifiedVerdict) matching) + in tshow parityCount <> "/" <> tshow (length matching) <> suffix origin + suffix FromBinding = " (RFC 8785 canonical form)" + suffix HistoricalGolden = "" + +renderDifference :: ClassifiedObservation -> [Text] +renderDifference observation = case classifiedVerdict observation of + JsonParity -> [] + RequiresVersionWork difference -> + [ " " <> classifiedName observation <> " [" <> direction <> "] at " <> pointerOf difference + , " " <> reasonOf difference + ] + where + direction = case classifiedOrigin observation of + FromBinding -> "encode" + HistoricalGolden -> "decode" + +renderInputIssue :: CompareInputIssue -> Text +renderInputIssue issue = case issue of + HistoricalGoldenUnreadable path reason -> T.pack path <> ": unreadable historical golden: " <> reason + HistoricalCodecRejected path reason -> T.pack path <> ": historical codec rejected its alleged golden: " <> reason + HistoricalCodecProvenanceInvalid reason -> reason + +renderCoverageGap :: CoverageGap -> Text +renderCoverageGap gap = + originName (cgOrigin gap) + <> " " + <> renderPointer (cgPointer gap) + <> ": " + <> branchKindName (cgKind gap) + +pointerOf :: ComparisonDifference -> Text +pointerOf difference = case difference of + EncodedValueDifference pointer _ _ -> renderPointer pointer + DecodedValueDifference pointer _ _ -> renderPointer pointer + GeneratedDecodeRejected _ -> "" + +reasonOf :: ComparisonDifference -> Text +reasonOf difference = case difference of + EncodedValueDifference _ historical generated -> + "historical and generated encoders produced different JSON values: " <> valuePair historical generated + DecodedValueDifference _ historical generated -> + "historical and generated decoders normalized to different structural values: " <> valuePair historical generated + GeneratedDecodeRejected reason -> "generated structural decoder rejected historical JSON: " <> reason + +valuePair :: Value -> Value -> Text +valuePair historical generated = "historical=" <> tshow historical <> "; generated=" <> tshow generated + +renderPointer :: JsonPointer -> Text +renderPointer (JsonPointer pointer) + | T.null pointer = "" + | otherwise = pointer + +writeCompareReportAtomic :: FilePath -> CompareReport -> IO (Either ReportWriteError ()) +writeCompareReportAtomic path report = do + let directory = takeDirectory path + template = takeFileName path <> ".tmp" + result <- try $ do + createDirectoryIfMissing True directory + bracketOnError + (openBinaryTempFile directory template) + cleanupTemporary + ( \(temporary, handle) -> do + LazyByteString.hPut handle (Aeson.encode report) + hClose handle + renameFile temporary path + ) + pure $ case result of + Left err -> Left (ReportWriteError path (T.pack (displayException (err :: IOException)))) + Right () -> Right () + +cleanupTemporary :: (FilePath, Handle) -> IO () +cleanupTemporary (temporary, handle) = do + _ <- try (hClose handle) :: IO (Either IOException ()) + exists <- doesFileExist temporary + when exists (removeFile temporary) + +firstDivergentPointer :: Value -> Value -> JsonPointer +firstDivergentPointer = go "" + where + go pointer (Object historical) (Object generated) = + case firstDifferentKey historical generated of + Nothing -> JsonPointer pointer + Just key -> case (KeyMap.lookup (Key.fromText key) historical, KeyMap.lookup (Key.fromText key) generated) of + (Just historicalValue, Just generatedValue) -> go (appendPointer pointer key) historicalValue generatedValue + _ -> JsonPointer (appendPointer pointer key) + go pointer (Array historical) (Array generated) = + let historicalValues = toList historical + generatedValues = toList generated + in case firstDifferentIndex historicalValues generatedValues of + Nothing -> JsonPointer pointer + Just index -> case (indexMaybe index historicalValues, indexMaybe index generatedValues) of + (Just historicalValue, Just generatedValue) -> go (appendPointer pointer (tshow index)) historicalValue generatedValue + _ -> JsonPointer (appendPointer pointer (tshow index)) + go pointer _ _ = JsonPointer pointer + +firstDifferentKey :: KeyMap.KeyMap Value -> KeyMap.KeyMap Value -> Maybe Text +firstDifferentKey historical generated = + firstMatch differs allKeys + where + allKeys = sort (map Key.toText (KeyMap.keys historical <> KeyMap.keys generated)) + differs key = KeyMap.lookup (Key.fromText key) historical /= KeyMap.lookup (Key.fromText key) generated + +firstDifferentIndex :: [Value] -> [Value] -> Maybe Int +firstDifferentIndex historical generated = + firstMatch differs [0 .. max (length historical) (length generated) - 1] + where + differs index = indexMaybe index historical /= indexMaybe index generated + +indexMaybe :: Int -> [a] -> Maybe a +indexMaybe index values = case drop index values of + value : _ -> Just value + [] -> Nothing + +firstMatch :: (a -> Bool) -> [a] -> Maybe a +firstMatch predicate = \case + [] -> Nothing + value : rest + | predicate value -> Just value + | otherwise -> firstMatch predicate rest + +appendPointer :: Text -> Text -> Text +appendPointer base segment = base <> "/" <> escapePointerSegment segment + +escapePointerSegment :: Text -> Text +escapePointerSegment = T.replace "/" "~1" . T.replace "~" "~0" + +tshow :: (Show a) => a -> Text +tshow = T.pack . show + +codeText :: DiagnosticCode -> Text +codeText = T.pack . show + +originName :: FixtureOrigin -> Text +originName HistoricalGolden = "historical-golden" +originName FromBinding = "typed-fixture" + +parseOrigin :: Text -> Parser FixtureOrigin +parseOrigin "historical-golden" = pure HistoricalGolden +parseOrigin "typed-fixture" = pure FromBinding +parseOrigin value = fail ("unknown fixture origin: " <> T.unpack value) + +branchKindName :: BranchKind -> Text +branchKindName kind = case kind of + UnionArm arm -> "union-arm:" <> arm + OptionalPresent -> "optional-present" + OptionalMissing -> "optional-missing" + ExplicitNull -> "explicit-null" + +parseBranchKind :: Text -> Parser BranchKind +parseBranchKind value + | Just arm <- T.stripPrefix "union-arm:" value = pure (UnionArm arm) + | value == "optional-present" = pure OptionalPresent + | value == "optional-missing" = pure OptionalMissing + | value == "explicit-null" = pure ExplicitNull + | otherwise = fail ("unknown branch kind: " <> T.unpack value) + +instance ToJSON FixtureOrigin where + toJSON = String . originName + +instance FromJSON FixtureOrigin where + parseJSON = withText "FixtureOrigin" parseOrigin + +instance ToJSON JsonPointer where + toJSON = String . unJsonPointer + +instance FromJSON JsonPointer where + parseJSON = withText "JsonPointer" (pure . JsonPointer) + +instance ToJSON BranchKind where + toJSON = String . branchKindName + +instance FromJSON BranchKind where + parseJSON = withText "BranchKind" parseBranchKind + +instance ToJSON ComparisonDifference where + toJSON difference = case difference of + EncodedValueDifference pointer historical generated -> + differenceObject "encoded-value-difference" pointer "encoder outputs differ" historical generated + DecodedValueDifference pointer historical generated -> + differenceObject "decoded-value-difference" pointer "normalized decoder outputs differ" historical generated + GeneratedDecodeRejected reason -> + object + [ "kind" .= ("generated-decode-rejected" :: Text) + , "pointer" .= JsonPointer "" + , "reason" .= reason + ] + where + differenceObject kind pointer reason historical generated = + object + [ "kind" .= (kind :: Text) + , "pointer" .= pointer + , "reason" .= (reason :: Text) + , "historical" .= historical + , "generated" .= generated + ] + +instance FromJSON ComparisonDifference where + parseJSON = withObject "ComparisonDifference" $ \value -> do + kind <- value .: "kind" :: Parser Text + case kind of + "encoded-value-difference" -> EncodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated" + "decoded-value-difference" -> DecodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated" + "generated-decode-rejected" -> GeneratedDecodeRejected <$> value .: "reason" + _ -> fail ("unknown comparison difference: " <> T.unpack kind) + +instance ToJSON FixtureVerdict where + toJSON JsonParity = object ["verdict" .= ("json-parity" :: Text)] + toJSON (RequiresVersionWork difference) = + object + [ "verdict" .= ("requires-version-work" :: Text) + , "code" .= codeText CodecCompareDifference + , "difference" .= difference + ] + +instance FromJSON FixtureVerdict where + parseJSON = withObject "FixtureVerdict" $ \value -> do + verdict <- value .: "verdict" :: Parser Text + case verdict of + "json-parity" -> pure JsonParity + "requires-version-work" -> RequiresVersionWork <$> value .: "difference" + _ -> fail ("unknown fixture verdict: " <> T.unpack verdict) + +instance ToJSON CompareInputIssue where + toJSON issue = case issue of + HistoricalGoldenUnreadable path reason -> issueObject "historical-golden-unreadable" path reason + HistoricalCodecRejected path reason -> issueObject "historical-codec-rejected" path reason + HistoricalCodecProvenanceInvalid reason -> + object + [ "code" .= codeText CodecCompareInvalidInput + , "kind" .= ("historical-codec-provenance-invalid" :: Text) + , "reason" .= reason + ] + where + issueObject kind path reason = + object + [ "code" .= codeText CodecCompareInvalidInput + , "kind" .= (kind :: Text) + , "path" .= path + , "reason" .= reason + ] + +instance FromJSON CompareInputIssue where + parseJSON = withObject "CompareInputIssue" $ \value -> do + kind <- value .: "kind" :: Parser Text + case kind of + "historical-golden-unreadable" -> HistoricalGoldenUnreadable <$> value .: "path" <*> value .: "reason" + "historical-codec-rejected" -> HistoricalCodecRejected <$> value .: "path" <*> value .: "reason" + "historical-codec-provenance-invalid" -> HistoricalCodecProvenanceInvalid <$> value .: "reason" + _ -> fail ("unknown comparison input issue: " <> T.unpack kind) + +instance ToJSON DeclaredBranch where + toJSON branch = + object + [ "origin" .= dbOrigin branch + , "pointer" .= dbPointer branch + , "branch" .= dbKind branch + ] + +instance FromJSON DeclaredBranch where + parseJSON = withObject "DeclaredBranch" $ \value -> + DeclaredBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch" + +instance ToJSON ObservedBranch where + toJSON branch = + object + [ "origin" .= obOrigin branch + , "pointer" .= obPointer branch + , "branch" .= obKind branch + ] + +instance FromJSON ObservedBranch where + parseJSON = withObject "ObservedBranch" $ \value -> + ObservedBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch" + +instance ToJSON CoverageGap where + toJSON gap = + object + [ "code" .= codeText CodecCompareCoverageGap + , "origin" .= cgOrigin gap + , "pointer" .= cgPointer gap + , "branch" .= cgKind gap + ] + +instance FromJSON CoverageGap where + parseJSON = withObject "CoverageGap" $ \value -> + CoverageGap <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch" + +instance ToJSON CompareProvenance where + toJSON provenance = + object + [ "historicalCodecIdentity" .= cpHistoricalCodecIdentity provenance + , "historicalCodecVersion" .= cpHistoricalCodecVersion provenance + , "canonicalType" .= unCanonicalTypeId (cpCanonicalType provenance) + , "bindingSymbol" .= unQualifiedValueName (cpBindingSymbol provenance) + , "bindingVersion" .= unBindingVersion (cpBindingVersion provenance) + , "wireFingerprint" .= cpWireFingerprint provenance + ] + +instance FromJSON CompareProvenance where + parseJSON = withObject "CompareProvenance" $ \value -> + CompareProvenance + <$> value .: "historicalCodecIdentity" + <*> value .: "historicalCodecVersion" + <*> (CanonicalTypeId <$> value .: "canonicalType") + <*> (QualifiedValueName <$> value .: "bindingSymbol") + <*> (BindingVersion <$> value .: "bindingVersion") + <*> value .: "wireFingerprint" + +instance ToJSON ClassifiedObservation where + toJSON observation = + object + [ "origin" .= classifiedOrigin observation + , "name" .= classifiedName observation + , "result" .= classifiedVerdict observation + ] + +instance FromJSON ClassifiedObservation where + parseJSON = withObject "ClassifiedObservation" $ \value -> + ClassifiedObservation <$> value .: "origin" <*> value .: "name" <*> value .: "result" + +instance ToJSON CompareReport where + toJSON report = + object + [ "schema" .= ("keiro-dsl/codec-compare-report/1" :: Text) + , "authority" .= crAuthority report + , "provenance" .= crProvenance report + , "success" .= reportSucceeded report + , "summary" + .= object + [ "observations" .= length (crObservations report) + , "parity" .= length (filter ((== JsonParity) . classifiedVerdict) (crObservations report)) + , "differences" .= length (filter ((/= JsonParity) . classifiedVerdict) (crObservations report)) + , "inputIssues" .= length (crInputIssues report) + , "coverageGaps" .= length (crCoverageGaps report) + ] + , "observations" .= crObservations report + , "inputIssues" .= crInputIssues report + , "coverageGaps" .= crCoverageGaps report + ] + +instance FromJSON CompareReport where + parseJSON = withObject "CompareReport" $ \value -> + CompareReport + <$> value .: "provenance" + <*> value .: "observations" + <*> value .: "inputIssues" + <*> value .: "coverageGaps" + <*> value .: "authority" diff --git a/src/Keiro/Dsl/Coverage.hs b/src/Keiro/Dsl/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Coverage.hs @@ -0,0 +1,650 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +{- | Reporting-only structural coverage over the checked mapped-type graph. + +The report intentionally has no aggregate percentage. Private persisted event +payloads and mapped register cache boundaries have different authorities, and +queue/public-contract payloads are not represented by this graph at all. +-} +module Keiro.Dsl.Coverage ( + CoverageSurface (..), + CoverageMode (..), + CoverageRoot (..), + StructuralBoundary (..), + OpaqueBoundary (..), + JsonBoundary (..), + SnapshotBoundary (..), + UnsupportedSurface (..), + CoverageCounts (..), + CoverageSummary (..), + CoverageFinding (..), + CoveragePrevious (..), + CoverageDelta (..), + CoverageReport (..), + coverageReport, + coverageDiffReport, + failOnOpaque, + failOnOpaqueIncrease, + coverageSucceeded, + renderCoverageSummary, + renderCoverageFinding, + writeCoverageReport, +) where + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (DiagnosticCode (..), Severity (..)) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) + +data CoverageSurface = PrivateEventPayload | SnapshotRegister + deriving stock (Eq, Ord, Show) + +data CoverageMode = StructuralCoverage | OpaqueCoverage + deriving stock (Eq, Ord, Show) + +data CoverageRoot = CoverageRoot + { rootSurface :: !CoverageSurface + , rootPath :: !Text + , rootMappedType :: !Text + , rootMode :: !CoverageMode + , rootCanonicalType :: !(Maybe Text) + , rootCodecIdentity :: !(Maybe Text) + , rootCodecVersion :: !(Maybe Text) + , rootWireFingerprint :: !Text + } + deriving stock (Eq, Ord, Show) + +data StructuralBoundary = StructuralBoundary + { structuralRoot :: !Text + , structuralPath :: !Text + , structuralMappedType :: !Text + , structuralCanonicalType :: !Text + , structuralWireFingerprint :: !Text + } + deriving stock (Eq, Ord, Show) + +data OpaqueBoundary = OpaqueBoundary + { opaqueRoot :: !Text + , opaquePath :: !Text + , opaqueMappedType :: !Text + , opaqueCodecIdentity :: !Text + , opaqueCodecVersion :: !Text + } + deriving stock (Eq, Ord, Show) + +data JsonBoundary = JsonBoundary + { jsonRoot :: !Text + , jsonPath :: !Text + } + deriving stock (Eq, Ord, Show) + +data SnapshotBoundary = SnapshotBoundary + { snapshotRoot :: !Text + , snapshotAggregate :: !Text + , snapshotRegister :: !Text + , snapshotMappedType :: !Text + , snapshotMode :: !CoverageMode + , snapshotEncoding :: !Text + , snapshotInvalidation :: !Text + , snapshotWireFingerprint :: !Text + , snapshotEnabled :: !Bool + } + deriving stock (Eq, Ord, Show) + +data UnsupportedSurface = UnsupportedSurface + { unsupportedSurface :: !Text + , unsupportedSupport :: !Text + , unsupportedReason :: !Text + } + deriving stock (Eq, Ord, Show) + +data CoverageCounts = CoverageCounts + { totalRoots :: !Int + , structuralRoots :: !Int + , opaqueRoots :: !Int + , jsonBoundaries :: !Int + } + deriving stock (Eq, Show) + +data CoverageSummary = CoverageSummary + { privateEventPayloads :: !CoverageCounts + , snapshotRegisters :: !CoverageCounts + } + deriving stock (Eq, Show) + +data CoverageFinding = CoverageFinding + { findingSeverity :: !Severity + , findingCode :: !DiagnosticCode + , findingRoots :: ![Text] + , findingMessage :: !Text + } + deriving stock (Eq, Show) + +data CoveragePrevious = CoveragePrevious + { previousReference :: !Text + , previousSummary :: !CoverageSummary + , previousOpaqueBoundaries :: ![OpaqueBoundary] + } + deriving stock (Eq, Show) + +data CoverageDelta = CoverageDelta + { privateEventRootDelta :: !Int + , snapshotRegisterRootDelta :: !Int + , opaqueBoundaryDelta :: !Int + , addedOpaqueBoundaries :: ![OpaqueBoundary] + , removedOpaqueBoundaries :: ![OpaqueBoundary] + } + deriving stock (Eq, Show) + +data CoverageReport = CoverageReport + { coverageSpec :: !FilePath + , coverageRoots :: ![CoverageRoot] + , coverageStructuralBoundaries :: ![StructuralBoundary] + , coverageOpaqueBoundaries :: ![OpaqueBoundary] + , coverageJsonBoundaries :: ![JsonBoundary] + , coverageSnapshotBoundaries :: ![SnapshotBoundary] + , coverageUnsupportedSurfaces :: ![UnsupportedSurface] + , coverageSummary :: !CoverageSummary + , coverageFindings :: ![CoverageFinding] + , coveragePrevious :: !(Maybe CoveragePrevious) + , coverageDelta :: !(Maybe CoverageDelta) + } + deriving stock (Eq, Show) + +coverageReport :: FilePath -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport +coverageReport specPath spec = do + graph <- resolveTypeGraph spec + let roots = sortOn rootPath (map (coverageRoot graph) (persistedSites graph)) + structural = structuralBoundaryInventory graph + opaque = opaqueBoundaryInventory graph + json = jsonBoundaryInventory graph + snapshots = snapshotBoundaryInventory spec graph + summary = summarize roots json + findings = opaqueSurfaceFindings opaque + pure + CoverageReport + { coverageSpec = specPath + , coverageRoots = roots + , coverageStructuralBoundaries = structural + , coverageOpaqueBoundaries = opaque + , coverageJsonBoundaries = json + , coverageSnapshotBoundaries = snapshots + , coverageUnsupportedSurfaces = unsupportedInventory + , coverageSummary = summary + , coverageFindings = findings + , coveragePrevious = Nothing + , coverageDelta = Nothing + } + +coverageDiffReport :: FilePath -> Text -> Spec -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport +coverageDiffReport specPath reference oldSpec newSpec = do + oldReport <- coverageReport (T.unpack reference <> ":" <> specPath) oldSpec + newReport <- coverageReport specPath newSpec + let oldOpaque = Set.fromList (coverageOpaqueBoundaries oldReport) + newOpaque = Set.fromList (coverageOpaqueBoundaries newReport) + added = Set.toAscList (newOpaque `Set.difference` oldOpaque) + removed = Set.toAscList (oldOpaque `Set.difference` newOpaque) + oldSummary = coverageSummary oldReport + newSummary = coverageSummary newReport + delta = + CoverageDelta + { privateEventRootDelta = totalRoots (privateEventPayloads newSummary) - totalRoots (privateEventPayloads oldSummary) + , snapshotRegisterRootDelta = totalRoots (snapshotRegisters newSummary) - totalRoots (snapshotRegisters oldSummary) + , opaqueBoundaryDelta = length added - length removed + , addedOpaqueBoundaries = added + , removedOpaqueBoundaries = removed + } + addedFindings = + [ CoverageFinding + { findingSeverity = Warning + , findingCode = CoverageOpaqueBoundaryAdded + , findingRoots = [opaqueRoot boundary] + , findingMessage = "opaque boundary added at " <> opaquePath boundary + } + | boundary <- added + ] + pure + newReport + { coverageFindings = coverageFindings newReport <> addedFindings + , coveragePrevious = + Just + CoveragePrevious + { previousReference = reference + , previousSummary = oldSummary + , previousOpaqueBoundaries = coverageOpaqueBoundaries oldReport + } + , coverageDelta = Just delta + } + +failOnOpaque :: CoverageReport -> CoverageReport +failOnOpaque report + | null boundaries = report + | otherwise = report{coverageFindings = coverageFindings report <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]} + where + boundaries = coverageOpaqueBoundaries report + +failOnOpaqueIncrease :: CoverageReport -> CoverageReport +failOnOpaqueIncrease report = case coverageDelta report of + Just delta + | not (null (addedOpaqueBoundaries delta)) -> + report + { coverageFindings = + coverageFindings report + <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" (addedOpaqueBoundaries delta)] + } + _ -> report + +coverageSucceeded :: CoverageReport -> Bool +coverageSucceeded = all ((/= Error) . findingSeverity) . coverageFindings + +renderCoverageSummary :: CoverageReport -> Text +renderCoverageSummary report = + T.unlines + [ "structural/opaque boundaries (reporting only):" + , " private-event-payloads: " <> renderCounts (privateEventPayloads summary) + , " snapshot-registers: " <> renderCounts (snapshotRegisters summary) <> "; encoding=consumer-json-cache; invalidation=tracked" + , " queue-payloads: unsupported" + , " public-contracts: not-applicable (separately owned grammar)" + ] + where + summary = coverageSummary report + renderCounts counts = + T.pack (show (totalRoots counts)) + <> " mapped roots (" + <> T.pack (show (structuralRoots counts)) + <> " structural, " + <> T.pack (show (opaqueRoots counts)) + <> " opaque, " + <> T.pack (show (jsonBoundaries counts)) + <> " Json boundaries)" + +renderCoverageFinding :: FilePath -> CoverageFinding -> Text +renderCoverageFinding specPath finding = + T.pack specPath + <> ":0: " + <> severityText (findingSeverity finding) + <> "[" + <> T.pack (show (findingCode finding)) + <> "]: " + <> findingMessage finding + <> rootsSuffix + where + severityText Error = "error" + severityText Warning = "warning" + rootsSuffix = case findingRoots finding of + [] -> "" + roots -> " (roots: " <> T.intercalate ", " roots <> ")" + +writeCoverageReport :: FilePath -> CoverageReport -> IO () +writeCoverageReport path report = do + createDirectoryIfMissing True (takeDirectory path) + Aeson.encodeFile path report + +persistedSites :: TypeGraph -> [UseSite] +persistedSites = filter isPersisted . tgUseSites + where + isPersisted RootEventField{} = True + isPersisted RootRegister{} = True + isPersisted RootCommandField{} = False + +coverageRoot :: TypeGraph -> UseSite -> CoverageRoot +coverageRoot graph site = + let key = useSiteKey site + path = renderUsePath (UsePath site []) + fingerprint = wireFingerprint graph (unMappedKey key) + in case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> + CoverageRoot + { rootSurface = useSiteSurface site + , rootPath = path + , rootMappedType = unMappedKey key + , rootMode = StructuralCoverage + , rootCanonicalType = Just (unCanonicalTypeId (sdCanonical declaration)) + , rootCodecIdentity = Nothing + , rootCodecVersion = Nothing + , rootWireFingerprint = fingerprint + } + Just (ResolvedOpaque declaration) -> + CoverageRoot + { rootSurface = useSiteSurface site + , rootPath = path + , rootMappedType = unMappedKey key + , rootMode = OpaqueCoverage + , rootCanonicalType = Nothing + , rootCodecIdentity = Just (unCodecIdentity (odCodecIdentity declaration)) + , rootCodecVersion = Just (unCodecVersion (odCodecVersion declaration)) + , rootWireFingerprint = fingerprint + } + Nothing -> error "coverageRoot: resolved use-site key missing from graph" + +structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary] +structuralBoundaryInventory graph = + sortOn + structuralPath + [ StructuralBoundary + { structuralRoot = rootText (upRoot path) + , structuralPath = renderUsePath path + , structuralMappedType = sdName declaration + , structuralCanonicalType = unCanonicalTypeId (sdCanonical declaration) + , structuralWireFingerprint = wireFingerprint graph (sdName declaration) + } + | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph) + , path <- usePaths graph (sdName declaration) + , isEventSite (upRoot path) + ] + +opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary] +opaqueBoundaryInventory graph = + sortOn + opaquePath + [ OpaqueBoundary + { opaqueRoot = rootText (upRoot path) + , opaquePath = renderUsePath path + , opaqueMappedType = odName declaration + , opaqueCodecIdentity = unCodecIdentity (odCodecIdentity declaration) + , opaqueCodecVersion = unCodecVersion (odCodecVersion declaration) + } + | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph) + , path <- usePaths graph (odName declaration) + , isEventSite (upRoot path) + ] + +jsonBoundaryInventory :: TypeGraph -> [JsonBoundary] +jsonBoundaryInventory graph = + sortOn + jsonPath + [ JsonBoundary + { jsonRoot = rootText site + , jsonPath = renderUsePath (UsePath site segments) + } + | site <- persistedSites graph + , isEventSite site + , segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site) + ] + +snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary] +snapshotBoundaryInventory spec graph = + sortOn + snapshotRoot + [ SnapshotBoundary + { snapshotRoot = renderUsePath (UsePath site []) + , snapshotAggregate = aggregate + , snapshotRegister = register + , snapshotMappedType = unMappedKey key + , snapshotMode = declarationMode declaration + , snapshotEncoding = "consumer-json-cache" + , snapshotInvalidation = "tracked-by-mapped-wire-fingerprint" + , snapshotWireFingerprint = wireFingerprint graph (unMappedKey key) + , snapshotEnabled = aggregateHasSnapshot aggregate + } + | site@(RootRegister aggregate register key) <- persistedSites graph + , Just declaration <- [Map.lookup key (tgDeclarations graph)] + ] + where + aggregateHasSnapshot name = + any + (\case NAggregate aggregate -> aggName aggregate == name && maybe False (const True) (aggSnapshot aggregate); _ -> False) + (specNodes spec) + +jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]] +jsonPathsFromDecl graph visited key + | key `Set.member` visited = [] + | otherwise = case Map.lookup key (tgDeclarations graph) of + Nothing -> [] + Just declaration -> + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> jsonPathsFromShape graph (Set.insert key visited) shape + , onOpaqueDecl = const [] + } + declaration + +jsonPathsFromShape :: TypeGraph -> Set.Set MappedKey -> ResolvedMappedShape -> [[PathSeg]] +jsonPathsFromShape graph visited = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + concat + [ map (SegField (rwfHaskell field) (rwfKey field) :) (jsonPathsFromExpr graph visited (rwfType field)) + | field <- fields + ] + , onEnum = const [] + , onUnion = \_ arms -> + concat + [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (jsonPathsFromExpr graph visited) (rwaPayload arm)) + | arm <- arms + ] + } + +jsonPathsFromExpr :: TypeGraph -> Set.Set MappedKey -> ResolvedTypeExpr -> [[PathSeg]] +jsonPathsFromExpr graph visited = + foldTypeExpr + TypeExprAlgebra + { onText = [] + , onInt = [] + , onBool = [] + , onNatural = [] + , onTime = [] + , onJson = [[]] + , onOptional = map (SegOptional :) + , onList = map (SegElem :) + , onMap = map (SegMapValue :) + , onRef = \key -> map (SegDecl (unMappedKey key) :) (jsonPathsFromDecl graph visited key) + } + +summarize :: [CoverageRoot] -> [JsonBoundary] -> CoverageSummary +summarize roots json = + CoverageSummary + { privateEventPayloads = countsFor PrivateEventPayload + , snapshotRegisters = countsFor SnapshotRegister + } + where + countsFor surface = + let matching = filter ((== surface) . rootSurface) roots + jsonCount = case surface of + PrivateEventPayload -> length json + SnapshotRegister -> 0 + in CoverageCounts + { totalRoots = length matching + , structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching) + , opaqueRoots = length (filter ((== OpaqueCoverage) . rootMode) matching) + , jsonBoundaries = jsonCount + } + +opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding] +opaqueSurfaceFindings boundaries = + [ CoverageFinding + { findingSeverity = Warning + , findingCode = CoverageOpaqueSurface + , findingRoots = [root] + , findingMessage = "persisted private-event root contains opaque mapped boundaries" + } + | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries)) + ] + +gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding +gateFinding message boundaries = + CoverageFinding + { findingSeverity = Error + , findingCode = CoverageOpaqueGateExceeded + , findingRoots = Set.toAscList (Set.fromList (map opaqueRoot boundaries)) + , findingMessage = message + } + +unsupportedInventory :: [UnsupportedSurface] +unsupportedInventory = + [ UnsupportedSurface + { unsupportedSurface = "queue-payloads" + , unsupportedSupport = "unsupported" + , unsupportedReason = "queue payloads are not roots in the mapped-type graph" + } + , UnsupportedSurface + { unsupportedSurface = "public-contracts" + , unsupportedSupport = "not-applicable" + , unsupportedReason = "public contracts have a separately owned grammar and compatibility surface" + } + ] + +useSiteKey :: UseSite -> MappedKey +useSiteKey (RootCommandField _ _ _ key) = key +useSiteKey (RootEventField _ _ _ key) = key +useSiteKey (RootRegister _ _ key) = key + +useSiteSurface :: UseSite -> CoverageSurface +useSiteSurface RootEventField{} = PrivateEventPayload +useSiteSurface RootRegister{} = SnapshotRegister +useSiteSurface RootCommandField{} = error "command fields are not persisted coverage roots" + +isEventSite :: UseSite -> Bool +isEventSite RootEventField{} = True +isEventSite RootRegister{} = False +isEventSite RootCommandField{} = False + +rootText :: UseSite -> Text +rootText site = renderUsePath (UsePath site []) + +declarationMode :: ResolvedMappedDecl -> CoverageMode +declarationMode = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ _ -> StructuralCoverage + , onOpaqueDecl = const OpaqueCoverage + } + +instance ToJSON CoverageSurface where + toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text) + toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text) + +instance ToJSON CoverageMode where + toJSON StructuralCoverage = toJSON ("structural" :: Text) + toJSON OpaqueCoverage = toJSON ("opaque" :: Text) + +instance ToJSON CoverageRoot where + toJSON root = + object + [ "surface" .= rootSurface root + , "path" .= rootPath root + , "mappedType" .= rootMappedType root + , "mode" .= rootMode root + , "canonicalType" .= rootCanonicalType root + , "codecIdentity" .= rootCodecIdentity root + , "codecVersion" .= rootCodecVersion root + , "wireFingerprint" .= rootWireFingerprint root + ] + +instance ToJSON StructuralBoundary where + toJSON boundary = + object + [ "root" .= structuralRoot boundary + , "path" .= structuralPath boundary + , "mappedType" .= structuralMappedType boundary + , "canonicalType" .= structuralCanonicalType boundary + , "wireFingerprint" .= structuralWireFingerprint boundary + ] + +instance ToJSON OpaqueBoundary where + toJSON boundary = + object + [ "root" .= opaqueRoot boundary + , "path" .= opaquePath boundary + , "mappedType" .= opaqueMappedType boundary + , "codecIdentity" .= opaqueCodecIdentity boundary + , "codecVersion" .= opaqueCodecVersion boundary + ] + +instance ToJSON JsonBoundary where + toJSON boundary = object ["root" .= jsonRoot boundary, "path" .= jsonPath boundary] + +instance ToJSON SnapshotBoundary where + toJSON boundary = + object + [ "root" .= snapshotRoot boundary + , "aggregate" .= snapshotAggregate boundary + , "register" .= snapshotRegister boundary + , "mappedType" .= snapshotMappedType boundary + , "mode" .= snapshotMode boundary + , "snapshotEncoding" .= snapshotEncoding boundary + , "invalidation" .= snapshotInvalidation boundary + , "wireFingerprint" .= snapshotWireFingerprint boundary + , "snapshotEnabled" .= snapshotEnabled boundary + ] + +instance ToJSON UnsupportedSurface where + toJSON surface = + object + [ "surface" .= unsupportedSurface surface + , "support" .= unsupportedSupport surface + , "reason" .= unsupportedReason surface + ] + +instance ToJSON CoverageCounts where + toJSON counts = + object + [ "totalRoots" .= totalRoots counts + , "structuralRoots" .= structuralRoots counts + , "opaqueRoots" .= opaqueRoots counts + , "jsonBoundaries" .= jsonBoundaries counts + ] + +instance ToJSON CoverageSummary where + toJSON summary = + object + [ "privateEventPayloads" .= privateEventPayloads summary + , "snapshotRegisters" .= snapshotRegisters summary + ] + +instance ToJSON CoverageFinding where + toJSON finding = + object + [ "severity" .= severityValue (findingSeverity finding) + , "code" .= show (findingCode finding) + , "roots" .= findingRoots finding + , "message" .= findingMessage finding + ] + where + severityValue Error = "error" :: Text + severityValue Warning = "advisory" + +instance ToJSON CoveragePrevious where + toJSON previous = + object + [ "reference" .= previousReference previous + , "summary" .= previousSummary previous + , "opaqueBoundaries" .= previousOpaqueBoundaries previous + ] + +instance ToJSON CoverageDelta where + toJSON delta = + object + [ "privateEventRootDelta" .= privateEventRootDelta delta + , "snapshotRegisterRootDelta" .= snapshotRegisterRootDelta delta + , "opaqueBoundaryDelta" .= opaqueBoundaryDelta delta + , "addedOpaqueBoundaries" .= addedOpaqueBoundaries delta + , "removedOpaqueBoundaries" .= removedOpaqueBoundaries delta + ] + +instance ToJSON CoverageReport where + toJSON report = + object + [ "schema" .= ("keiro-dsl/coverage-report/1" :: Text) + , "spec" .= coverageSpec report + , "roots" .= coverageRoots report + , "structuralBoundaries" .= coverageStructuralBoundaries report + , "opaqueBoundaries" .= coverageOpaqueBoundaries report + , "jsonBoundaries" .= coverageJsonBoundaries report + , "snapshotBoundaries" .= coverageSnapshotBoundaries report + , "unsupportedSurfaces" .= coverageUnsupportedSurfaces report + , "summary" .= coverageSummary report + , "findings" .= coverageFindings report + , "previous" .= coveragePrevious report + , "delta" .= coverageDelta report + ] diff --git a/src/Keiro/Dsl/Diff.hs b/src/Keiro/Dsl/Diff.hs --- a/src/Keiro/Dsl/Diff.hs +++ b/src/Keiro/Dsl/Diff.hs @@ -15,6 +15,27 @@ module Keiro.Dsl.Diff ( Change (..), ChangeKind (..), + Label (..), + CompatibilitySurface (..), + SurfaceVerdict (..), + RolloutConstraint (..), + CompatibilityVector (..), + ChangeContext, + privateEventContext, + privateEventAdditionContext, + snapshotContext, + queueContext, + publicContractContext, + persistedIdentityContext, + consumerBuildContext, + changeContextRoot, + changeContextPaths, + classifyCompatibility, + verdictFor, + defaultGate, + gateWith, + deriveLabel, + gatedBreaking, isBreaking, isAdvisory, diffSpecs, @@ -31,10 +52,22 @@ import Data.List (find, (\\)) import Data.Maybe (isJust, isNothing, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface) import Keiro.Dsl.Grammar +import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject) +import Keiro.Dsl.PrettyPrint ( + renderHandleSurface, + renderResolveSurface, + renderRouterDispatchSurface, + renderTimerPayloadSurface, + renderTransition, + ) import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor) +import Keiro.Dsl.TypeGraph (UsePath (..), UseSite (..)) import Keiro.Dsl.Validate (DiagnosticCode (..)) -- | A classified spec change. @@ -44,15 +77,419 @@ | Breaking ChangeKind deriving stock (Eq, Show) +-- | The stable headline classification retained by the text interface. +data Label = LabelAdditive | LabelAdvisory | LabelBreaking + deriving stock (Eq, Show) + +-- | Independently gateable compatibility questions for one finding. +data CompatibilitySurface + = PrivateHistoryRead + | OldBinaryReadNewEvents + | SnapshotHydration + | PublicConsumer + | PersistedIdentity + | ConsumerBuild + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | A verdict on one surface. Constructor order is deliberately not policy. +data SurfaceVerdict = VCompatible | VAdvisory | VBreaking | VNotApplicable + deriving stock (Eq, Show) + +-- | Deployment ordering that remains after byte compatibility is classified. +data RolloutConstraint + = RolloutStopTheWorld + | RolloutWorkersFirst + | RolloutDrainRequired + | RolloutProducerLast + deriving stock (Eq, Ord, Show) + +-- | The explicit, compile-forcing compatibility result for one finding. +data CompatibilityVector = CompatibilityVector + { cvPrivateHistoryRead :: !SurfaceVerdict + , cvOldBinaryReadNewEvents :: !SurfaceVerdict + , cvSnapshotHydration :: !SurfaceVerdict + , cvPublicConsumer :: !SurfaceVerdict + , cvPersistedIdentity :: !SurfaceVerdict + , cvConsumerBuild :: !SurfaceVerdict + , cvRollout :: !(Set RolloutConstraint) + } + deriving stock (Eq, Show) + +data ContextKind + = ContextGeneral + | ContextPrivateEvent + | ContextPrivateEventAddition + | ContextSnapshot + | ContextQueue + | ContextPublicContract + | ContextPersistedIdentity + | ContextConsumerBuild + deriving stock (Eq, Show) + +{- | Facts that select a compatibility row. The constructor stays private so +callers cannot manufacture contradictory ownership and surface claims. +-} +data ChangeContext = ChangeContext + { changeContextRoot :: !Name + , changeContextPaths :: ![Text] + , contextKind :: !ContextKind + , contextOriginalLabel :: !Label + } + deriving stock (Eq, Show) + data ChangeKind = ChangeKind { ckNode :: !Name , ckFacet :: !Text , ckSubject :: !Text - , ckCode :: !(Maybe DiagnosticCode) + , ckCode :: !DiagnosticCode + , ckContext :: !ChangeContext + , ckVector :: !CompatibilityVector + , ckPaths :: ![Text] , ckDetail :: !Text } deriving stock (Eq, Show) +privateEventContext :: Name -> [Text] -> ChangeContext +privateEventContext root paths = ChangeContext root paths ContextPrivateEvent LabelBreaking + +privateEventAdditionContext :: Name -> [Text] -> ChangeContext +privateEventAdditionContext root paths = ChangeContext root paths ContextPrivateEventAddition LabelAdvisory + +snapshotContext :: Name -> [Text] -> ChangeContext +snapshotContext root paths = ChangeContext root paths ContextSnapshot LabelAdvisory + +queueContext :: Name -> [Text] -> ChangeContext +queueContext root paths = ChangeContext root paths ContextQueue LabelBreaking + +publicContractContext :: Name -> [Text] -> ChangeContext +publicContractContext root paths = ChangeContext root paths ContextPublicContract LabelBreaking + +persistedIdentityContext :: Name -> [Text] -> ChangeContext +persistedIdentityContext root paths = ChangeContext root paths ContextPersistedIdentity LabelBreaking + +consumerBuildContext :: Name -> [Text] -> ChangeContext +consumerBuildContext root paths = ChangeContext root paths ContextConsumerBuild LabelAdvisory + +compatibleVector :: CompatibilityVector +compatibleVector = + CompatibilityVector + VCompatible + VCompatible + VNotApplicable + VNotApplicable + VNotApplicable + VNotApplicable + Set.empty + +privateDecodeBreakingVector :: CompatibilityVector +privateDecodeBreakingVector = + CompatibilityVector + VBreaking + VBreaking + VAdvisory + VNotApplicable + VNotApplicable + VNotApplicable + (Set.singleton RolloutStopTheWorld) + +persistedIdentityBreakingVector :: CompatibilityVector +persistedIdentityBreakingVector = + CompatibilityVector + VNotApplicable + VNotApplicable + VNotApplicable + VNotApplicable + VBreaking + VNotApplicable + Set.empty + +publicBreakingVector :: CompatibilityVector +publicBreakingVector = + CompatibilityVector + VNotApplicable + VNotApplicable + VNotApplicable + VBreaking + VNotApplicable + VNotApplicable + (Set.singleton RolloutProducerLast) + +queueBreakingVector :: CompatibilityVector +queueBreakingVector = + CompatibilityVector + VBreaking + VBreaking + VNotApplicable + VNotApplicable + VAdvisory + VNotApplicable + (Set.singleton RolloutWorkersFirst) + +advisoryVector :: CompatibilitySurface -> Set RolloutConstraint -> CompatibilityVector +advisoryVector surface rollout = + compatibleVector + { cvPrivateHistoryRead = verdict PrivateHistoryRead + , cvOldBinaryReadNewEvents = verdict OldBinaryReadNewEvents + , cvSnapshotHydration = verdict SnapshotHydration + , cvPublicConsumer = verdict PublicConsumer + , cvPersistedIdentity = verdict PersistedIdentity + , cvConsumerBuild = verdict ConsumerBuild + , cvRollout = rollout + } + where + verdict candidate + | candidate == surface = VAdvisory + | otherwise = verdictFor candidate compatibleVector + +{- | Classify one code at an explicitly owned use site. Codes emitted by the +differ are grouped by their actual persisted/public surface; the context is +load-bearing for codes such as 'EnumCtorAdded' that vary by use site. +-} +classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector +classifyCompatibility context code + | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context + | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context + | code `elem` mappedWireBreakingCodes = mappedWireBreakingVector context + | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] = mappedBuildVector + | code == MappedBindingChanged = mappedBindingVector context + | code `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] = mappedSnapshotBuildVector context + | code == MappedDeclAdded = compatibleVector + | code `elem` privateDecodeCodes = privateDecodeBreakingVector + | code `elem` identityCodes = persistedIdentityBreakingVector + | code `elem` publicBreakingCodes = publicBreakingVector + | code `elem` queueBreakingCodes = queueBreakingVector + | code `elem` readModelBreakingCodes = persistedIdentityBreakingVector + | code == ContractSchemaVersionBumped = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast) + | code == AggFoldSurfaceChanged = + (advisoryVector PrivateHistoryRead Set.empty){cvSnapshotHydration = VAdvisory} + | code == AggGuardTightened = advisoryVector PrivateHistoryRead Set.empty + | code `elem` [RouterDecideSurfaceChanged, ProcessDecideSurfaceChanged] = + compatibleVector{cvRollout = Set.singleton RolloutDrainRequired} + | code == ProcessTimerPayloadChanged = advisoryVector PrivateHistoryRead (Set.singleton RolloutProducerLast) + | code == TimerWindowChanged = advisoryVector PrivateHistoryRead Set.empty + | code == ProjectionChanged = advisoryVector PersistedIdentity Set.empty + | code == EmitMappingChanged = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast) + | code == DecodePostureChanged = advisoryVector PublicConsumer Set.empty + | code == IntakePersistenceChanged = advisoryVector PrivateHistoryRead Set.empty + | code `elem` [PublisherPolicyChanged, DispatchRetargeted] = advisoryVector PersistedIdentity Set.empty + | code `elem` [DeprecatedEventReplayHazard, EventRetirementInProgress] = advisoryVector PrivateHistoryRead Set.empty + | code == EventUndeprecated = advisoryVector OldBinaryReadNewEvents (Set.singleton RolloutProducerLast) + | code == EnumCtorAdded = case contextKind context of + ContextPrivateEventAddition -> + compatibleVector + { cvOldBinaryReadNewEvents = VBreaking + , cvRollout = Set.singleton RolloutProducerLast + } + ContextSnapshot -> advisoryVector SnapshotHydration Set.empty + _ -> compatibleVector + | code `elem` additiveCodes = compatibleVector + | otherwise = case contextOriginalLabel context of + LabelAdditive -> compatibleVector + LabelAdvisory -> advisoryVector (surfaceForContext context) Set.empty + LabelBreaking -> breakingVectorForContext context + where + privateDecodeCodes = + [ EvtFieldAddedWithoutBump + , EvtFieldRemovedSameVersion + , EvtFieldTypeChanged + , EvtVersionDecreased + , EvtVersionMissingUpcaster + , UpcasterChainGap + , EvtRemovedNotDeprecated + , EnumCtorRemoved + , EnumWireSpellingChanged + , WireSpecChanged + , ProcessInputChanged + , WorkflowShapeChanged + , WorkflowBodyChanged + , WorkflowPatchRemoved + , WorkflowContinueSeedChanged + ] + identityCodes = + [ DerivedIdentityChanged + , IdPrefixChanged + , DedupeIdentityChanged + , QueueIdentityChanged + , RouterStableNameChanged + , WorkflowStableNameChanged + ] + publicBreakingCodes = + [ ContractEventRemoved + , ContractFieldChanged + , ContractDiscriminatorChanged + , ContractTopicChanged + , ContractSchemaVersionDecreased + ] + queueBreakingCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged] + readModelBreakingCodes = + [ ReadModelVersionDecreased + , ReadModelShapeChangedWithoutBump + , ReadModelFeedChanged + , ReadModelConsistencyWeakened + ] + additiveCodes = + [ DeclarationAdded + , VersionBumped + , CompatibilityStrengthened + , EventRetirementAbandoned + , ContractEventAdded + , ContractTopicAdded + , WorkflowEvolutionGuardAdded + ] + +mappedWireBreakingCodes :: [DiagnosticCode] +mappedWireBreakingCodes = + [ MappedFieldAddedNoDefault + , MappedFieldRemoved + , MappedFieldTypeChanged + , MappedPresenceChanged + , MappedNullabilityChanged + , MappedDefaultRemoved + , MappedDefaultChanged + , MappedWireKeyChanged + , MappedUnionEncodingChanged + , MappedArmRemoved + , MappedArmTagChanged + , MappedEnumValueRemoved + , MappedEnumSpellingChanged + , MappedOpaqueCodecChanged + , MappedModeCrossed + , MappedDeclRemoved + ] + +mappedFieldAdditionVector :: ChangeContext -> CompatibilityVector +mappedFieldAdditionVector context = case contextKind context of + ContextPrivateEvent -> + compatibleVector + { cvOldBinaryReadNewEvents = oldBinaryVerdict + , cvRollout = rollout + } + where + rejectsUnknown = contextOriginalLabel context == LabelBreaking + oldBinaryVerdict = if rejectsUnknown then VBreaking else VCompatible + rollout = if rejectsUnknown then Set.singleton RolloutProducerLast else Set.empty + ContextSnapshot -> mappedSnapshotVector + ContextConsumerBuild -> mappedBuildVector + _ -> compatibleVector + +mappedDirectionalAdditionVector :: ChangeContext -> CompatibilityVector +mappedDirectionalAdditionVector context = case contextKind context of + ContextPrivateEvent -> + compatibleVector + { cvOldBinaryReadNewEvents = VBreaking + , cvRollout = Set.singleton RolloutProducerLast + } + ContextSnapshot -> mappedSnapshotVector + ContextConsumerBuild -> mappedBuildVector + _ -> compatibleVector + +mappedWireBreakingVector :: ChangeContext -> CompatibilityVector +mappedWireBreakingVector context = case contextKind context of + ContextPrivateEvent -> + CompatibilityVector + VBreaking + VBreaking + VNotApplicable + VNotApplicable + VNotApplicable + VNotApplicable + (Set.singleton RolloutStopTheWorld) + ContextSnapshot -> mappedSnapshotVector + ContextConsumerBuild -> mappedBuildVector + _ -> mappedBuildVector + +mappedBuildVector :: CompatibilityVector +mappedBuildVector = + CompatibilityVector + VCompatible + VCompatible + VNotApplicable + VNotApplicable + VNotApplicable + VAdvisory + Set.empty + +mappedSnapshotVector :: CompatibilityVector +mappedSnapshotVector = + CompatibilityVector + VCompatible + VCompatible + VAdvisory + VNotApplicable + VNotApplicable + VNotApplicable + Set.empty + +mappedBindingVector :: ChangeContext -> CompatibilityVector +mappedBindingVector context = case contextKind context of + ContextPrivateEvent -> + CompatibilityVector + VAdvisory + VAdvisory + VNotApplicable + VNotApplicable + VNotApplicable + VAdvisory + Set.empty + ContextSnapshot -> + mappedSnapshotVector{cvConsumerBuild = VAdvisory} + _ -> mappedBuildVector + +mappedSnapshotBuildVector :: ChangeContext -> CompatibilityVector +mappedSnapshotBuildVector context = case contextKind context of + ContextSnapshot -> mappedSnapshotVector{cvConsumerBuild = VAdvisory} + _ -> mappedBuildVector + +surfaceForContext :: ChangeContext -> CompatibilitySurface +surfaceForContext context = case contextKind context of + ContextPrivateEvent -> PrivateHistoryRead + ContextPrivateEventAddition -> OldBinaryReadNewEvents + ContextSnapshot -> SnapshotHydration + ContextQueue -> PrivateHistoryRead + ContextPublicContract -> PublicConsumer + ContextPersistedIdentity -> PersistedIdentity + ContextConsumerBuild -> ConsumerBuild + ContextGeneral -> PrivateHistoryRead + +breakingVectorForContext :: ChangeContext -> CompatibilityVector +breakingVectorForContext context = case contextKind context of + ContextPublicContract -> publicBreakingVector + ContextPersistedIdentity -> persistedIdentityBreakingVector + ContextQueue -> queueBreakingVector + ContextConsumerBuild -> (advisoryVector ConsumerBuild Set.empty){cvConsumerBuild = VBreaking} + _ -> privateDecodeBreakingVector + +verdictFor :: CompatibilitySurface -> CompatibilityVector -> SurfaceVerdict +verdictFor surface vector = case surface of + PrivateHistoryRead -> cvPrivateHistoryRead vector + OldBinaryReadNewEvents -> cvOldBinaryReadNewEvents vector + SnapshotHydration -> cvSnapshotHydration vector + PublicConsumer -> cvPublicConsumer vector + PersistedIdentity -> cvPersistedIdentity vector + ConsumerBuild -> cvConsumerBuild vector + +defaultGate :: Set CompatibilitySurface +defaultGate = Set.delete OldBinaryReadNewEvents (Set.fromList [minBound .. maxBound]) + +gateWith :: [CompatibilitySurface] -> Set CompatibilitySurface +gateWith surfaces = defaultGate <> Set.fromList surfaces + +deriveLabel :: Set CompatibilitySurface -> CompatibilityVector -> Label +deriveLabel gate vector + | any ((== VBreaking) . (`verdictFor` vector)) (Set.toList gate) = LabelBreaking + | any (`elem` [VAdvisory, VBreaking]) verdicts || not (Set.null (cvRollout vector)) = LabelAdvisory + | otherwise = LabelAdditive + where + verdicts = [verdictFor surface vector | surface <- [minBound .. maxBound]] + +gatedBreaking :: Set CompatibilitySurface -> Change -> Bool +gatedBreaking gate change = deriveLabel gate (ckVector (changeKind change)) == LabelBreaking + +changeKind :: Change -> ChangeKind +changeKind (Additive kind) = kind +changeKind (Advisory kind) = kind +changeKind (Breaking kind) = kind + isBreaking :: Change -> Bool isBreaking (Breaking _) = True isBreaking (Additive _) = False @@ -168,12 +605,75 @@ runFamily env (DiffFamily f) = f env runFamily _ (OutOfDiffScope _) = [] --- Rules are intentionally outside the decode/identity axes: they alter guard --- behaviour but neither interpret stored bytes nor derive persisted keys. --- Shared id and enum declarations become diffed in Milestones 2 and 4. +-- Rules are outside the decode and persisted-identity axes, but referenced +-- rule bodies are compared as part of each aggregate's replay fold surface. sharedDeclarationDiff :: DiffEnv -> [Change] -sharedDeclarationDiff env = enumDiff env ++ idDiff env +sharedDeclarationDiff env = enumDiff env ++ idDiff env ++ mappedDeclarationDiff env +mappedDeclarationDiff :: DiffEnv -> [Change] +mappedDeclarationDiff env = concatMap mappedFindingChanges (diffMapped (deOld env) (deNew env)) + +mappedFindingChanges :: MappedFinding -> [Change] +mappedFindingChanges finding + | mfCode finding == MappedDeclAdded = [mappedDeclarationChange LabelAdditive finding] + | mfCode finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] = + [mappedBuildChange finding] + | mfCode finding `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] = + mappedBuildChange finding : map (mappedUseChange finding) registerPaths + | null paths = [mappedBuildChange finding] + | otherwise = map (mappedUseChange finding) paths + where + paths = mfUsePaths finding + registerPaths = [path | path@UsePath{upRoot = RootRegister{}} <- paths] + +mappedBuildChange :: MappedFinding -> Change +mappedBuildChange finding = + mappedChange context (mfDeclaration finding) "mapped-build" subject finding + where + subject = declarationSubject finding + renderedPaths = map (\path -> renderMappedSubject path (mfLeaf finding)) (mfUsePaths finding) + context = (consumerBuildContext (mfDeclaration finding) renderedPaths){contextOriginalLabel = LabelAdvisory} + +mappedDeclarationChange :: Label -> MappedFinding -> Change +mappedDeclarationChange label finding = + mappedChange context (mfDeclaration finding) "mapped-declaration" (declarationSubject finding) finding + where + context = ChangeContext (mfDeclaration finding) [] ContextGeneral label + +mappedUseChange :: MappedFinding -> UsePath -> Change +mappedUseChange finding path = + mappedChange context root facet subject finding + where + subject = renderMappedSubject path (mfLeaf finding) + (root, facet, kind) = case upRoot path of + RootCommandField aggregate _ _ _ -> (aggregate, "mapped-command", ContextConsumerBuild) + RootEventField aggregate _ _ _ -> (aggregate, "mapped-event", ContextPrivateEvent) + RootRegister aggregate _ _ -> (aggregate, "mapped-register", ContextSnapshot) + context = ChangeContext root [subject] kind (mappedContextHint finding kind) + +mappedContextHint :: MappedFinding -> ContextKind -> Label +mappedContextHint finding kind = case kind of + ContextSnapshot -> LabelAdvisory + ContextConsumerBuild -> LabelAdvisory + ContextPrivateEvent + | mfCode finding == MappedFieldAddedWithDefault -> case mfOldUnknownFields finding of + Just IgnoreUnknown -> LabelAdditive + _ -> LabelBreaking + | mfCode finding `elem` [MappedArmAdded, MappedEnumValueAdded] -> LabelAdvisory + | mfCode finding `elem` [MappedBindingChanged, MappedInitialChanged, MappedCanonicalTypeChanged] -> LabelAdvisory + | otherwise -> LabelBreaking + _ -> LabelAdvisory + +mappedChange :: ChangeContext -> Name -> Text -> Text -> MappedFinding -> Change +mappedChange context node facet subject finding = + mkChange label context node facet subject (mfCode finding) (mfDetail finding) + where + label = deriveLabel defaultGate (classifyCompatibility context (mfCode finding)) + +declarationSubject :: MappedFinding -> Text +declarationSubject finding = + mfDeclaration finding <> if T.null (mfLeaf finding) then "" else " " <> mfLeaf finding + nodeAggregate :: Node -> Maybe Aggregate nodeAggregate (NAggregate a) = Just a nodeAggregate _ = Nothing @@ -224,13 +724,17 @@ routerDiff :: DiffEnv -> [Change] routerDiff env = concatMap (uncurry routerPairDiff) (prMatched paired) - ++ [additive (rtId router) "router" (rtId router) "new router declaration" | router <- prAdded paired] + ++ [additive (rtId router) "router" (rtId router) DeclarationAdded "new router declaration" | router <- prAdded paired] ++ [breaking (rtId router) "router-identity" (rtId router) RouterStableNameChanged "router removed while replayable source events may still derive target-keyed dispatch ids from its stable identity" | router <- prRemoved paired] where paired = pairByName nodeRouter rtId env routerPairDiff :: RouterNode -> RouterNode -> [Change] -routerPairDiff oldRouter newRouter = stableName ++ keyDerivation ++ target +routerPairDiff oldRouter newRouter = + stableName + ++ keyDerivation + ++ target + ++ routerDecideSurfaceDiff oldRouter newRouter where nodeName = rtId newRouter stableName = @@ -247,6 +751,26 @@ | rtTarget oldRouter /= rtTarget newRouter ] +routerDecideSurfaceDiff :: RouterNode -> RouterNode -> [Change] +routerDecideSurfaceDiff oldRouter newRouter = + [ advisory + (rtId newRouter) + "router-decide" + (rtId newRouter) + RouterDecideSurfaceChanged + "router dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the router's subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too." + | oldSurface /= newSurface + ] + where + oldSurface = + ( renderResolveSurface (rtResolve oldRouter) + , renderRouterDispatchSurface (rtDispatch oldRouter) + ) + newSurface = + ( renderResolveSurface (rtResolve newRouter) + , renderRouterDispatchSurface (rtDispatch newRouter) + ) + readModelDiff :: DiffEnv -> [Change] readModelDiff env = concatMap (uncurry (readModelPairDiff env)) (prMatched paired) @@ -270,7 +794,7 @@ [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel)) ] | rmVersion newReadModel > rmVersion oldReadModel = - [ additive nodeName "read-model-version" nodeName ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it") + [ additive nodeName "read-model-version" nodeName VersionBumped ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it") ] | otherwise = [] oldShape = (rmColumns oldReadModel, rmShape oldReadModel) @@ -302,20 +826,20 @@ (Strong, Eventual) -> [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"] (Eventual, Strong) -> - [additive nodeName "read-model-consistency" nodeName "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"] + [additive nodeName "read-model-consistency" nodeName CompatibilityStrengthened "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"] _ -> [] oldScope = effectiveScope (rmScope oldReadModel) newScope = effectiveScope (rmScope newReadModel) scopeChanges | oldScope == newScope = [] | scopeStrengthened oldScope newScope = - [additive nodeName "read-model-scope" nodeName ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)] + [additive nodeName "read-model-scope" nodeName CompatibilityStrengthened ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)] | otherwise = [breaking nodeName "read-model-scope" nodeName ReadModelConsistencyWeakened ("Strong scope changed " <> renderScope oldScope <> " -> " <> renderScope newScope <> "; callers no longer wait on the same event surface")] addedReadModelDiff :: ReadModelNode -> [Change] addedReadModelDiff readModel = - [additive (rmName readModel) "read-model" (rmName readModel) "new read model"] + [additive (rmName readModel) "read-model" (rmName readModel) DeclarationAdded "new read model"] removedReadModelDiff :: ReadModelNode -> [Change] removedReadModelDiff readModel = @@ -342,22 +866,92 @@ aggregateDiff :: DiffEnv -> [Change] aggregateDiff env = - concatMap (uncurry aggregatePairDiff) (prMatched paired) + concatMap + (\(oldAggregate, newAggregate) -> aggregatePairDiff (deOld env) (deNew env) oldAggregate newAggregate) + (prMatched paired) ++ concatMap addedAggregateDiff (prAdded paired) ++ concatMap removedAggregateDiff (prRemoved paired) where paired = pairByName nodeAggregate aggName env -aggregatePairDiff :: Aggregate -> Aggregate -> [Change] -aggregatePairDiff oldAgg newAgg = +aggregatePairDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change] +aggregatePairDiff oldSpec newSpec oldAgg newAgg = concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg) ++ removedEvents oldAgg newAgg ++ wireDiff oldAgg newAgg ++ projectionDiff oldAgg newAgg + ++ guardTighteningDiff oldAgg newAgg + ++ transitionSurfaceDiff oldSpec newSpec oldAgg newAgg +{- | Report replay-fold evolution. Regenerated scaffold code carries the new +fingerprint and invalidates old snapshots, so this remains advisory. +-} +transitionSurfaceDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change] +transitionSurfaceDiff oldSpec newSpec oldAgg newAgg + | aggregateFoldSurface oldSpec oldAgg == aggregateFoldSurface newSpec newAgg = [] + | otherwise = + [ advisory + (aggName newAgg) + "transitions" + (aggName newAgg) + AggFoldSurfaceChanged + "aggregate fold surface changed: replay now interprets the existing log under the new fold. Old snapshots are invalidated automatically once the regenerated fold fingerprint deploys; if the change is fold-neutral confirm it, otherwise re-scaffold and redeploy, and bump `state-codec version=` for any accompanying Holes-only change." + ] + +{- | Plan 143: guard changes are replay-relevant. Hydration re-inverts each +stored event and re-checks the edge guard, so a stored event legally appended +under the old guard may no longer satisfy the new one — the next command on +any stream containing such an event fails hydration with no inverting edge. +The remedy is mechanical, so the tool computes it: the removed region is +@old-guard ∧ ¬new-guard@ ('complementExpr' eliminates the negation inside the +existing grammar), and the advisory prints a paste-ready replay-only twin +carrying that region with the OLD transition's writes\/emits\/goto. Whether +history should stay replayable (paste the twin) or be truncated instead is a +business decision, so the twin is never auto-applied. + +Detection is conservative: any guard change on a paired live (source, +command) transition where the new spec declares a guard and does not already +contain a replay-only twin for the pair. A pure loosening also matches; the +advisory says how to confirm no stored data is affected (the replay audit, +docs/plans/142) rather than guessing. +-} +guardTighteningDiff :: Aggregate -> Aggregate -> [Change] +guardTighteningDiff oldAgg newAgg = + [ advisory (aggName newAgg) "transition" subject AggGuardTightened detail + | newT <- aggTransitions newAgg + , tMode newT == TmLive + , Just oldT <- + [ find + (\o -> tSource o == tSource newT && tCommand o == tCommand newT && tMode o == TmLive) + (aggTransitions oldAgg) + ] + , tGuard newT /= tGuard oldT + , Just newGuard <- [tGuard newT] + , not (hasReplayOnlyTwin newT) + , let subject = tSource newT <> " -- " <> tCommand newT + , let removedRegion = + maybe (complementExpr newGuard) (\o -> EAnd o (complementExpr newGuard)) (tGuard oldT) + , let twin = oldT{tGuard = Just removedRegion, tMode = TmReplayOnly} + , let detail = + "guard changed on " + <> subject + <> ". Stored events appended under the old guard may no longer invert: " + <> "the next command on any stream containing one fails hydration with " + <> "no inverting edge. Either confirm via the replay audit that no stored " + <> "stream exercises the removed region, or keep history replayable by " + <> "adding the computed replay-only twin (the removed region with the old " + <> "transition's writes/emits/goto):\n\n" + <> renderTransition twin + ] + where + hasReplayOnlyTwin newT = + any + (\t -> tMode t == TmReplayOnly && tSource t == tSource newT && tCommand t == tCommand newT) + (aggTransitions newAgg) + addedAggregateDiff :: Aggregate -> [Change] addedAggregateDiff newAgg = - [ additive (aggName newAgg) "event" (evName e) "new event type (new aggregate)" + [ additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type (new aggregate)" | e <- aggEvents newAgg ] @@ -372,11 +966,30 @@ eventDiff oldAgg newAgg e = case find ((== evName e) . evName) (aggEvents oldAgg) of Nothing -> - [additive (aggName newAgg) "event" (evName e) "new event type"] + [additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type"] Just oldE | evVersion e > evVersion oldE -> if evVersion e == evVersion oldE + 1 && evUpcastFrom e `hasSource` evVersion oldE - then [additive (aggName newAgg) "event" (evName e) ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))] + then + [additive (aggName newAgg) "event" (evName e) VersionBumped ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))] + ++ [ breaking + (aggName newAgg) + "event" + (evName e) + UpcasterChainGap + ( "bumping v" + <> tInt (evVersion oldE) + <> " to v" + <> tInt (evVersion e) + <> " replaced the 'upcast from v" + <> tInt vanishedSource + <> "' rung; stored v" + <> tInt vanishedSource + <> " payloads can no longer decode" + ) + | Just (vanishedSource, _) <- [evUpcastFrom oldE] + , not (aggregateHasUpcasterSource newAgg vanishedSource) + ] else [ breaking (aggName newAgg) @@ -397,11 +1010,12 @@ sameVersionEventDiff oldAgg newAgg oldE e {- | Events present in the old aggregate but absent in the new one. Removing a -tag entirely is breaking; keeping it as a deprecated event is safe. +tag entirely is breaking; deprecation preserves decoding but needs a retained +replay-only emitter to preserve replay. -} removedEvents :: Aggregate -> Aggregate -> [Change] removedEvents oldAgg newAgg = - [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; keep it as a 'deprecated event' so old payloads still decode" + [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; its stored payloads can neither decode nor replay. Deprecating instead restores decode-ability only — replay still fails on live streams unless an equivalent replay-only emitting transition is retained; truncate or terminalize affected streams before deleting it" | oldE <- aggEvents oldAgg , isNothing (find ((== evName oldE) . evName) (aggEvents newAgg)) ] @@ -410,6 +1024,16 @@ hasSource (Just (m, _)) n = m == n hasSource Nothing _ = False +aggregateHasUpcasterSource :: Aggregate -> Int -> Bool +aggregateHasUpcasterSource aggregate source = + any ((== Just source) . fmap fst . evUpcastFrom) (aggEvents aggregate) + +hasReplayOnlyEmitter :: Aggregate -> Name -> Bool +hasReplayOnlyEmitter aggregate eventName = + any + (\transition -> tMode transition == TmReplayOnly && eventName `elem` tEmits transition) + (aggTransitions aggregate) + eventFieldSigs :: Aggregate -> Event -> [(Name, Maybe Name)] eventFieldSigs agg e = case evBody e of EventFields fs -> map fieldSig fs @@ -424,6 +1048,7 @@ ++ removedChanges ++ typeChanges ++ deprecationChanges + ++ retirementChanges where oldFields = eventFieldSigs oldAgg oldE newFields = eventFieldSigs newAgg newE @@ -456,10 +1081,33 @@ ] deprecationChanges | not (evDeprecated oldE) && evDeprecated newE = - [additive (aggName newAgg) "event" (evName newE) "event deprecated (still decodable)"] - | evDeprecated oldE && not (evDeprecated newE) = + [ if hasReplayOnlyEmitter newAgg (evName newE) + then + advisory + (aggName newAgg) + "event" + (evName newE) + EventRetirementInProgress + "event deprecated and removed from the live write path, while an equivalent replay-only transition preserves hydration. Retain that transition until every affected stream is terminal, truncated, or passes the replay audit" + else + advisory + (aggName newAgg) + "event" + (evName newE) + DeprecatedEventReplayHazard + ( "event deprecated: old payloads remain decodable but are no longer replayable — hydration of live streams containing them fails at the first command (HydrationNoInvertingEdge). Add an equivalent replay-only emitting transition or confirm every affected stream is terminal or truncated before deploying" + <> if evRetiring oldE then "" else "; consider a 'retiring event' stage first" + ) + ] + | evDeprecated oldE && not (evDeprecated newE) && not (evRetiring newE) = [advisory (aggName newAgg) "event" (evName newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"] | otherwise = [] + retirementChanges + | not (evRetiring oldE) && evRetiring newE = + [advisory (aggName newAgg) "event" (evName newE) EventRetirementInProgress "retirement started; keep the live emitting transition until affected streams are terminal or truncated, then cut over to deprecated plus an equivalent replay-only emitting transition"] + | evRetiring oldE && not (evRetiring newE) && not (evDeprecated newE) = + [additive (aggName newAgg) "event" (evName newE) EventRetirementAbandoned "event retirement abandoned; ordinary live writes continue"] + | otherwise = [] renderFieldType :: Maybe Name -> Text renderFieldType Nothing = "(declared)" @@ -516,7 +1164,7 @@ ] addedIdDiff :: IdDecl -> [Change] -addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) "new id declaration"] +addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) DeclarationAdded "new id declaration"] removedIdDiff :: IdDecl -> [Change] removedIdDiff declaration = [breaking (idName declaration) "id-prefix" (idName declaration) IdPrefixChanged "id declaration removed; persisted ids still use its prefix"] @@ -540,15 +1188,46 @@ , Just newWire <- [lookup ctor (enumCtors newEnum)] , oldWire /= newWire ] - ++ [ additive (enumName newEnum) "enum-constructor" ctor ("new constructor with wire spelling '" <> wire <> "'") - | (ctor, wire) <- enumCtors newEnum - , isNothing (lookup ctor (enumCtors oldEnum)) - ] + ++ concat + [ enumAdditionDiff oldSpec newEnum ctor wire + | (ctor, wire) <- enumCtors newEnum + , isNothing (lookup ctor (enumCtors oldEnum)) + ] addedEnumDiff :: EnumDecl -> [Change] addedEnumDiff enumDecl = - [additive (enumName enumDecl) "enum-constructor" ctor ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl] + [additive (enumName enumDecl) "enum-constructor" ctor EnumCtorAdded ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl] +enumAdditionDiff :: Spec -> EnumDecl -> Name -> Text -> [Change] +enumAdditionDiff oldSpec enumDecl ctor wire = case enumUsages oldSpec (enumName enumDecl) of + [] -> + [ additive + (enumName enumDecl) + "enum-constructor" + ctor + EnumCtorAdded + ("new constructor with wire spelling '" <> wire <> "'") + ] + usages -> map finding usages + where + finding usage + | ".reg." `T.isInfixOf` usage = + advisoryAt + (snapshotContext (enumName enumDecl) [usage]) + (enumName enumDecl) + "enum-constructor" + ctor + EnumCtorAdded + ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; invalidate or rebuild snapshots before values using the new arm hydrate") + | otherwise = + advisoryAt + (privateEventAdditionContext (enumName enumDecl) [usage]) + (enumName enumDecl) + "enum-constructor" + ctor + EnumCtorAdded + ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; deploy consumers before producers emit the new arm") + removedEnumDiff :: Spec -> EnumDecl -> [Change] removedEnumDiff oldSpec enumDecl = [ breaking (enumName enumDecl) "enum-constructor" ctor EnumCtorRemoved ("enum removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName enumDecl)) @@ -626,13 +1305,13 @@ removedEvents' = prRemoved eventPairs eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent addedEventChanges event = - [additive (ctrName newContract) "contract-event" (ceName event) "new contract event"] + [additive (ctrName newContract) "contract-event" (ceName event) ContractEventAdded "new contract event"] removedEventChanges event = [breaking (ctrName newContract) "contract-event" (ceName event) ContractEventRemoved "contract event removed; existing cross-service payloads no longer have a declared decoder"] addedContractDiff :: ContractNode -> [Change] addedContractDiff contract = - [additive (ctrName contract) "contract-event" (ceName event) "new event in a new contract" | event <- ctrEvents contract] + [additive (ctrName contract) "contract-event" (ceName event) ContractEventAdded "new event in a new contract" | event <- ctrEvents contract] removedContractDiff :: ContractNode -> [Change] removedContractDiff contract = @@ -659,7 +1338,7 @@ , Just newTopic <- [lookup alias (ctrTopics newContract)] , oldTopic /= newTopic ] - ++ [ additive (ctrName newContract) "contract-topic" alias ("new topic alias for '" <> topic <> "'") + ++ [ additive (ctrName newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'") | (alias, topic) <- ctrTopics newContract , isNothing (lookup alias (ctrTopics oldContract)) ] @@ -730,17 +1409,17 @@ | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")] | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> wqfType oldField <> " -> " <> wqfType newField)] | not (wqfRequired oldField) && wqfRequired newField = [payloadBreaking newField "field changed from optional to required; queued jobs may omit it"] - | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) "field changed from required to optional"] + | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) CompatibilityStrengthened "field changed from required to optional"] | otherwise = [] addedFieldDiff field | wqfRequired field = [payloadBreaking field "new required field; queued jobs do not contain it"] - | otherwise = [additive (wqName newQueue) "payload-field" (wqfName field) "new optional field"] + | otherwise = [additive (wqName newQueue) "payload-field" (wqfName field) CompatibilityStrengthened "new optional field"] removedFieldDiff field = [payloadBreaking field "field removed; queued jobs still contain the old payload shape"] payloadBreaking field detail = breaking (wqName newQueue) "payload-field" (wqfName field) WqPayloadFieldChanged detail addedWorkqueueDiff :: WorkqueueNode -> [Change] addedWorkqueueDiff queue = - [additive (wqName queue) "payload-field" (wqfName field) "field belongs to a new workqueue payload" | field <- wqPayload queue] + [additive (wqName queue) "payload-field" (wqfName field) DeclarationAdded "field belongs to a new workqueue payload" | field <- wqPayload queue] removedWorkqueueDiff :: WorkqueueNode -> [Change] removedWorkqueueDiff queue = @@ -814,6 +1493,8 @@ ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields) ++ processIdentityDiff oldProcess newProcess ++ processTimerWindowDiff oldProcess newProcess + ++ processDecideSurfaceDiff oldProcess newProcess + ++ processTimerPayloadDiff oldProcess newProcess where -- inName is a generated Haskell type name; the wire shape is inFields. fields = pairDeclarations fieldName (inFields (procInput oldProcess)) (inFields (procInput newProcess)) @@ -824,7 +1505,7 @@ addedProcessDiff :: ProcessNode -> [Change] addedProcessDiff process = - [additive (procId process) "input-field" (fieldName field) "field belongs to a new process input" | field <- inFields (procInput process)] + [additive (procId process) "input-field" (fieldName field) DeclarationAdded "field belongs to a new process input" | field <- inFields (procInput process)] removedProcessDiff :: ProcessNode -> [Change] removedProcessDiff process = @@ -868,6 +1549,30 @@ | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess) ] +processDecideSurfaceDiff :: ProcessNode -> ProcessNode -> [Change] +processDecideSurfaceDiff oldProcess newProcess = + [ advisory + (procId newProcess) + "process-decide" + (procId newProcess) + ProcessDecideSurfaceChanged + "process dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the process subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too." + | renderHandleSurface (procHandle oldProcess) + /= renderHandleSurface (procHandle newProcess) + ] + +processTimerPayloadDiff :: ProcessNode -> ProcessNode -> [Change] +processTimerPayloadDiff oldProcess newProcess = + [ advisory + (procId newProcess) + "timer-payload" + (tmName (procTimer newProcess)) + ProcessTimerPayloadChanged + "timer payload shape changed: rows scheduled before the deploy carry the old shape, unversioned, and fire under new code — the fire decoder must accept every historically scheduled shape or the timer dead-letters after maxAttempts. Hole-only timer-decoder changes are not visible to diff; the same drain rule applies to those too." + | renderTimerPayloadSurface (procTimer oldProcess) + /= renderTimerPayloadSurface (procTimer newProcess) + ] + renderFireAt :: FireAtExpr -> Text renderFireAt expression = "input." <> faField expression <> " + " <> faWindow expression @@ -901,7 +1606,7 @@ workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail addedWorkflowDiff :: WorkflowNode -> [Change] -addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) "new workflow"] +addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) DeclarationAdded "new workflow"] removedWorkflowDiff :: WorkflowNode -> [Change] removedWorkflowDiff workflow = [breaking (wfId workflow) "workflow" (wfId workflow) WorkflowShapeChanged "workflow removed while in-flight journals and outcomes may still require its decoder"] @@ -965,7 +1670,7 @@ renderInkPersist InkPersistDedupeOnly = "dedupe-only" addedIntakeDiff :: IntakeNode -> [Change] -addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) "new intake"] +addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) DeclarationAdded "new intake"] removedIntakeDiff :: IntakeNode -> [Change] removedIntakeDiff intake = [breaking (inkName intake) "dedupe-identity" (inkName intake) DedupeIdentityChanged "intake removed while persisted dedupe records and redeliveries may remain"] @@ -1009,7 +1714,7 @@ emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit) addedEmitDiff :: EmitNode -> [Change] -addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) "new emit mapping"] +addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) DeclarationAdded "new emit mapping"] removedEmitDiff :: EmitNode -> [Change] removedEmitDiff emit = [breaking (emName emit) "derived-identity" (emName emit) DerivedIdentityChanged "emit removed while persisted outbox identities may still retry"] @@ -1043,7 +1748,7 @@ ] addedPublisherDiff :: PublisherNode -> [Change] -addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) "new publisher"] +addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) DeclarationAdded "new publisher"] removedPublisherDiff :: PublisherNode -> [Change] removedPublisherDiff publisher = [breaking (pubName publisher) "derived-identity" (pubName publisher) DerivedIdentityChanged "publisher removed while persisted outbox rows may still require its stable identity"] @@ -1088,7 +1793,7 @@ dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch) addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change] -addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) "new pgmq dispatch"] +addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) DeclarationAdded "new pgmq dispatch"] removedPgmqDispatchDiff :: PgmqDispatchNode -> [Change] removedPgmqDispatchDiff dispatch = [breaking (pdName dispatch) "dedupe-identity" (pdName dispatch) DedupeIdentityChanged "dispatch removed while persisted queue and read-model dedupe records may remain"] @@ -1106,7 +1811,7 @@ ] | safeAdditions = map addedPatch newPatchIds - ++ [ additive nodeName "workflow-continue-as-new" seedType "terminal continueAsNew is additive; old generations carry no rotation marker" + ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker" | Just seedType <- [appendedSeed] ] | otherwise = @@ -1144,7 +1849,7 @@ removedPatch patchId = breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch" addedPatch patchId = - additive nodeName "workflow-patch" patchId "new patch guard contains the entire body change, so in-flight generations retain their journaled branch" + additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch" normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem] normaliseWorkflowBody = map go @@ -1179,14 +1884,106 @@ WfContinueAsNew{} : rest -> reverse rest _ -> items -additive :: Name -> Text -> Text -> Text -> Change -additive n facet subj detail = Additive (ChangeKind n facet subj Nothing detail) +additive :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change +additive n facet subj code detail = + mkChange LabelAdditive (contextFor LabelAdditive n facet subj code) n facet subj code detail breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change -breaking n facet subj c detail = Breaking (ChangeKind n facet subj (Just c) detail) +breaking n facet subj code detail = + mkChange LabelBreaking (contextFor LabelBreaking n facet subj code) n facet subj code detail advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change -advisory n facet subj c detail = Advisory (ChangeKind n facet subj (Just c) detail) +advisory n facet subj code detail = + mkChange LabelAdvisory (contextFor LabelAdvisory n facet subj code) n facet subj code detail + +advisoryAt :: ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change +advisoryAt context n facet subj code detail = + mkChange LabelAdvisory context n facet subj code detail + +mkChange :: Label -> ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change +mkChange label context n facet subj code detail = + wrap + ChangeKind + { ckNode = n + , ckFacet = facet + , ckSubject = subj + , ckCode = code + , ckContext = context + , ckVector = classifyCompatibility context code + , ckPaths = changeContextPaths context + , ckDetail = detail + } + where + wrap = case label of + LabelAdditive -> Additive + LabelAdvisory -> Advisory + LabelBreaking -> Breaking + +contextFor :: Label -> Name -> Text -> Text -> DiagnosticCode -> ChangeContext +contextFor label root facet subject code = + setLabel $ case () of + _ + | code `elem` publicCodes -> publicContractContext root paths + | code `elem` queueCodes -> queueContext root paths + | code `elem` identityCodes -> persistedIdentityContext root paths + | code == AggFoldSurfaceChanged -> snapshotContext root paths + | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label + | code `elem` privateCodes -> privateEventContext root paths + | otherwise -> ChangeContext root paths ContextGeneral label + where + paths = [pathFor root facet subject] + setLabel context = context{contextOriginalLabel = label} + publicCodes = + [ ContractEventRemoved + , ContractFieldChanged + , ContractDiscriminatorChanged + , ContractTopicChanged + , ContractSchemaVersionDecreased + , ContractSchemaVersionBumped + , ContractEventAdded + , ContractTopicAdded + ] + queueCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged, QueueIdentityChanged] + identityCodes = + [ DerivedIdentityChanged + , IdPrefixChanged + , DedupeIdentityChanged + , RouterStableNameChanged + , WorkflowStableNameChanged + , ReadModelVersionDecreased + , ReadModelShapeChangedWithoutBump + , ReadModelFeedChanged + , ReadModelConsistencyWeakened + ] + privateCodes = + [ EvtFieldAddedWithoutBump + , EvtFieldRemovedSameVersion + , EvtFieldTypeChanged + , EvtVersionDecreased + , EvtVersionMissingUpcaster + , UpcasterChainGap + , EvtRemovedNotDeprecated + , EnumCtorRemoved + , EnumWireSpellingChanged + , WireSpecChanged + , ProcessInputChanged + , WorkflowShapeChanged + , WorkflowBodyChanged + , WorkflowPatchRemoved + , WorkflowContinueSeedChanged + , AggGuardTightened + , DeprecatedEventReplayHazard + , EventRetirementInProgress + , EventUndeprecated + , ProcessTimerPayloadChanged + ] + +pathFor :: Name -> Text -> Text -> Text +pathFor root facet subject + | facet `elem` ["event", "event-field"] = root <> ".event." <> subject + | facet `elem` ["contract-event", "contract-field"] = root <> ".event." <> subject + | root == subject = root <> "." <> facet + | otherwise = root <> "." <> facet <> "." <> subject commas :: [Text] -> Text commas = T.intercalate ", " diff --git a/src/Keiro/Dsl/DiffReport.hs b/src/Keiro/Dsl/DiffReport.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/DiffReport.hs @@ -0,0 +1,331 @@ +{- | Pure rendering and JSON encoding for compatibility-vector diff reports. + +The JSON schema identifier is @keiro-dsl/diff-report/1@. Consumers must +ignore unknown object keys. Vector keys and entries in the @paths@ array are +append-only so later nested type-expression work can refine findings without +invalidating version-1 readers. +-} +module Keiro.Dsl.DiffReport ( + Remedy (..), + DiffReport, + diffReport, + remediationFor, + renderRemedy, + renderFinding, + renderVectorLine, + renderExplainBlock, + surfaceName, + parseSurfaceName, + verdictName, + rolloutName, +) where + +import Data.Aeson (ToJSON (..), Value, object, (.=)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Diff +import Keiro.Dsl.Validate (DiagnosticCode (..)) + +data Remedy + = RemedyVersionBump + | RemedyUpcaster + | RemedyDeploymentOrder RolloutConstraint + | RemedyContractRevision + | RemedyReplayOnlyEdge + | RemedyStateCodecBump + | RemedyRecompileConsumers + | RemedyRunConformance + | RemedyDoNotDeploy Text + deriving stock (Eq, Show) + +data DiffReport = DiffReport + { reportGate :: !(Set CompatibilitySurface) + , reportFindings :: ![Change] + } + deriving stock (Eq, Show) + +diffReport :: Set CompatibilitySurface -> [Change] -> DiffReport +diffReport = DiffReport + +instance ToJSON DiffReport where + toJSON report = + object + [ "schema" .= ("keiro-dsl/diff-report/1" :: Text) + , "gate" .= map surfaceName (Set.toAscList (reportGate report)) + , "breaking" .= any (gatedBreaking (reportGate report)) (reportFindings report) + , "findings" .= map (findingValue (reportGate report)) (reportFindings report) + ] + +findingValue :: Set CompatibilitySurface -> Change -> Value +findingValue gate change = + object + [ "label" .= labelName (deriveLabel gate (ckVector kind)) + , "node" .= ckNode kind + , "facet" .= ckFacet kind + , "subject" .= ckSubject kind + , "code" .= T.pack (show (ckCode kind)) + , "paths" .= ckPaths kind + , "vector" .= vectorValue (ckVector kind) + , "detail" .= ckDetail kind + , "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind))) + ] + where + kind = changeKind change + +vectorValue :: CompatibilityVector -> Value +vectorValue vector = + object + [ "private-history-read" .= verdictName (cvPrivateHistoryRead vector) + , "old-binary-read-new-events" .= verdictName (cvOldBinaryReadNewEvents vector) + , "snapshot-hydration" .= verdictName (cvSnapshotHydration vector) + , "public-consumer" .= verdictName (cvPublicConsumer vector) + , "persisted-identity" .= verdictName (cvPersistedIdentity vector) + , "consumer-build" .= verdictName (cvConsumerBuild vector) + , "rollout" .= map rolloutName (Set.toAscList (cvRollout vector)) + ] + +remediationFor :: ChangeContext -> DiagnosticCode -> NonEmpty Remedy +remediationFor context code + | code == AggGuardTightened = RemedyReplayOnlyEdge :| [RemedyRunConformance] + | code == AggFoldSurfaceChanged = RemedyStateCodecBump :| [RemedyRunConformance] + | code `elem` mappedWireCodes = mappedWireRemedy + | code `elem` [MappedFieldAddedWithDefault, MappedArmAdded, MappedEnumValueAdded] = mappedAdditionRemedy + | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged] = + RemedyRecompileConsumers :| [RemedyRunConformance] + | code == MappedBindingChanged = mappedConformanceRemedy + | code == MappedFixturesChanged = RemedyRunConformance :| [] + | code == MappedInitialChanged = mappedSnapshotConformanceRemedy + | code == MappedCanonicalTypeChanged = mappedCanonicalRemedy + | code == MappedDeclAdded = RemedyRunConformance :| [] + | code `elem` eventDecodeCodes = + RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld] + | code `elem` contractCodes = + RemedyContractRevision :| [RemedyDeploymentOrder RolloutProducerLast] + | code `elem` queueCodes = + RemedyDeploymentOrder RolloutWorkersFirst :| [RemedyRunConformance] + | code `elem` identityCodes = + RemedyDoNotDeploy "revert the re-keying change or perform an explicit operational identity migration" :| [] + | code == EnumCtorAdded = case Set.toAscList (cvRollout vector) of + rollout : _ -> RemedyDeploymentOrder rollout :| [snapshotRemedy] + [] -> snapshotRemedy :| [] + | cvConsumerBuild vector `elem` [VAdvisory, VBreaking] = + RemedyRecompileConsumers :| [RemedyRunConformance] + | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance] + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance] + | otherwise = RemedyRunConformance :| [] + where + vector = classifyCompatibility context code + firstRollout = case Set.toAscList (cvRollout vector) of + rollout : _ -> Just rollout + [] -> Nothing + snapshotRemedy + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump + | otherwise = RemedyRunConformance + mappedWireRemedy + | cvPrivateHistoryRead vector == VBreaking = + RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld] + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance] + | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance] + mappedAdditionRemedy + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance] + | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance] + | otherwise = RemedyRunConformance :| [] + mappedConformanceRemedy + | cvSnapshotHydration vector == VAdvisory = RemedyRunConformance :| [RemedyStateCodecBump] + | otherwise = RemedyRunConformance :| [] + mappedSnapshotConformanceRemedy + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance] + | otherwise = RemedyRunConformance :| [] + mappedCanonicalRemedy + | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRecompileConsumers, RemedyRunConformance] + | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance] + mappedWireCodes = + [ MappedFieldAddedNoDefault + , MappedFieldRemoved + , MappedFieldTypeChanged + , MappedPresenceChanged + , MappedNullabilityChanged + , MappedDefaultRemoved + , MappedDefaultChanged + , MappedWireKeyChanged + , MappedUnionEncodingChanged + , MappedArmRemoved + , MappedArmTagChanged + , MappedEnumValueRemoved + , MappedEnumSpellingChanged + , MappedOpaqueCodecChanged + , MappedModeCrossed + , MappedDeclRemoved + ] + eventDecodeCodes = + [ EvtFieldAddedWithoutBump + , EvtFieldRemovedSameVersion + , EvtFieldTypeChanged + , EvtVersionDecreased + , EvtVersionMissingUpcaster + , UpcasterChainGap + , EvtRemovedNotDeprecated + , EnumCtorRemoved + , EnumWireSpellingChanged + , WireSpecChanged + , ProcessInputChanged + , WorkflowShapeChanged + , WorkflowBodyChanged + , WorkflowPatchRemoved + , WorkflowContinueSeedChanged + ] + contractCodes = + [ ContractEventRemoved + , ContractFieldChanged + , ContractDiscriminatorChanged + , ContractTopicChanged + , ContractSchemaVersionDecreased + , ContractSchemaVersionBumped + ] + queueCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged, QueueIdentityChanged] + identityCodes = + [ DerivedIdentityChanged + , IdPrefixChanged + , DedupeIdentityChanged + , RouterStableNameChanged + , WorkflowStableNameChanged + , ReadModelVersionDecreased + , ReadModelShapeChangedWithoutBump + , ReadModelFeedChanged + , ReadModelConsistencyWeakened + ] + +renderRemedy :: Remedy -> Text +renderRemedy remedy = case remedy of + RemedyVersionBump -> "bump the owning schema or event version" + RemedyUpcaster -> "add and retain a contiguous upcaster for every historical version" + RemedyDeploymentOrder rollout -> "deploy in " <> rolloutName rollout <> " order" + RemedyContractRevision -> "revise the independently owned public contract" + RemedyReplayOnlyEdge -> "add the computed replay-only edge described by docs/adr/0002-replay-only-edges-are-the-sanctioned-remedy-for-guard-tightening.md" + RemedyStateCodecBump -> "invalidate and rebuild snapshots by bumping state-codec version when automatic fingerprinting cannot see the change" + RemedyRecompileConsumers -> "recompile every affected consumer against the generated interface" + RemedyRunConformance -> "run the generated conformance and historical fixture suites" + RemedyDoNotDeploy detail -> detail + +renderFinding :: Change -> Text +renderFinding change = + headline + <> if vectorIsUniform (ckVector kind) + then "" + else "\n" <> renderVectorLine (ckVector kind) + where + kind = changeKind change + headline = + headlineName change + <> ": " + <> ckNode kind + <> " " + <> ckFacet kind + <> " " + <> ckSubject kind + <> ": " + <> ckDetail kind + <> codeSuffix change kind + +renderVectorLine :: CompatibilityVector -> Text +renderVectorLine vector = + " vector: " + <> T.unwords + ( [ surfaceName surface <> "=" <> verdictName verdict + | surface <- [minBound .. maxBound] + , let verdict = verdictFor surface vector + , verdict /= VNotApplicable + ] + <> ["rollout=" <> T.intercalate "," (map rolloutName (Set.toAscList (cvRollout vector))) | not (Set.null (cvRollout vector))] + ) + +renderExplainBlock :: Change -> Text +renderExplainBlock change = + "explain [" + <> T.pack (show (ckCode kind)) + <> "]\n" + <> T.unlines [" path: " <> path | path <- ckPaths kind] + <> T.unlines (map (" direction: " <>) directions) + <> T.unlines [" remedy: " <> renderRemedy remedy | remedy <- NonEmpty.toList remedies] + where + kind = changeKind change + vector = ckVector kind + directions = + [ surfaceName surface <> " is " <> verdictName verdict <> "; " <> directionMeaning surface verdict + | surface <- [minBound .. maxBound] + , let verdict = verdictFor surface vector + , verdict `elem` [VAdvisory, VBreaking] + ] + remedies = remediationFor (ckContext kind) (ckCode kind) + +surfaceName :: CompatibilitySurface -> Text +surfaceName surface = case surface of + PrivateHistoryRead -> "private-history-read" + OldBinaryReadNewEvents -> "old-binary-read-new-events" + SnapshotHydration -> "snapshot-hydration" + PublicConsumer -> "public-consumer" + PersistedIdentity -> "persisted-identity" + ConsumerBuild -> "consumer-build" + +parseSurfaceName :: String -> Either String CompatibilitySurface +parseSurfaceName raw = case lookup (T.pack raw) [(surfaceName surface, surface) | surface <- [minBound .. maxBound]] of + Just surface -> Right surface + Nothing -> + Left + ( "unknown compatibility surface '" + <> raw + <> "'; expected one of: " + <> T.unpack (T.intercalate ", " (map surfaceName [minBound .. maxBound])) + ) + +verdictName :: SurfaceVerdict -> Text +verdictName verdict = case verdict of + VCompatible -> "compatible" + VAdvisory -> "advisory" + VBreaking -> "breaking" + VNotApplicable -> "n/a" + +rolloutName :: RolloutConstraint -> Text +rolloutName rollout = case rollout of + RolloutStopTheWorld -> "stop-the-world" + RolloutWorkersFirst -> "workers-first" + RolloutDrainRequired -> "drain-required" + RolloutProducerLast -> "producer-last" + +labelName :: Label -> Text +labelName label = case label of + LabelAdditive -> "additive" + LabelAdvisory -> "warning" + LabelBreaking -> "breaking" + +headlineName :: Change -> Text +headlineName Additive{} = "ADDITIVE" +headlineName Advisory{} = "WARNING" +headlineName Breaking{} = "BREAKING" + +codeSuffix :: Change -> ChangeKind -> Text +codeSuffix Additive{} _ = "" +codeSuffix _ kind = " [" <> T.pack (show (ckCode kind)) <> "]" + +changeKind :: Change -> ChangeKind +changeKind (Additive kind) = kind +changeKind (Advisory kind) = kind +changeKind (Breaking kind) = kind + +vectorIsUniform :: CompatibilityVector -> Bool +vectorIsUniform vector = + Set.null (cvRollout vector) + && all (`elem` [VCompatible, VNotApplicable]) [verdictFor surface vector | surface <- [minBound .. maxBound]] + +directionMeaning :: CompatibilitySurface -> SurfaceVerdict -> Text +directionMeaning surface verdict = case (surface, verdict) of + (PrivateHistoryRead, _) -> "the candidate binary may reinterpret or fail to read stored private history" + (OldBinaryReadNewEvents, _) -> "a still-running old binary may reject events emitted by the candidate" + (SnapshotHydration, _) -> "persisted snapshot seeds require invalidation or rebuild" + (PublicConsumer, _) -> "an independently deployed consumer may reject the candidate contract" + (PersistedIdentity, _) -> "replay or retry may derive a different persisted identity" + (ConsumerBuild, _) -> "consumer or generated source must be rebuilt" diff --git a/src/Keiro/Dsl/ExplainBindings.hs b/src/Keiro/Dsl/ExplainBindings.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/ExplainBindings.hs @@ -0,0 +1,293 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +{- | Consumer-owned Haskell obligations implied by checked structural mapped +declarations. The same values drive create-once skeletons, scaffold-record +diffs, and the @check --explain-bindings@ report. +-} +module Keiro.Dsl.ExplainBindings ( + BindingObligationKind (..), + BindingObligation (..), + BindingHole (..), + bindingObligations, + bindingHoles, + renderBindingObligations, +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.List (groupBy, sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar (HaskellSource (..), Name, Spec (..), WireEnum (..)) +import Keiro.Dsl.TypeGraph + +data BindingObligationKind + = BindingValue + | FixtureValue + | InitialValue + deriving stock (Eq, Ord, Show) + +data BindingObligation = BindingObligation + { obligationMappedName :: !Name + , obligationPackage :: !Text + , obligationModule :: !Text + , obligationSymbol :: !Text + , obligationKind :: !BindingObligationKind + , obligationSignature :: !Text + , obligationUseSites :: ![Text] + , obligationBindingVersion :: !(Maybe Text) + } + deriving stock (Eq, Ord, Show) + +data BindingHole = BindingHole + { holeMappedName :: !Name + , holeModule :: !Text + , holeSymbol :: !Text + , holeKind :: !BindingObligationKind + , holePath :: !(Maybe Text) + , holeSignature :: !Text + } + deriving stock (Eq, Ord, Show) + +instance ToJSON BindingObligation where + toJSON obligation = + object + [ "schema" .= (1 :: Int) + , "mappedName" .= obligationMappedName obligation + , "package" .= obligationPackage obligation + , "module" .= obligationModule obligation + , "symbol" .= obligationSymbol obligation + , "kind" .= renderKind (obligationKind obligation) + , "signature" .= obligationSignature obligation + , "useSites" .= obligationUseSites obligation + , "bindingVersion" .= obligationBindingVersion obligation + ] + +instance FromJSON BindingObligation where + parseJSON = withObject "keiro-dsl binding obligation" $ \value -> do + schema <- value .: "schema" + if schema /= (1 :: Int) + then fail "unsupported binding obligation schema" + else do + kindText <- value .: "kind" + kindValue <- maybe (fail "unknown binding obligation kind") pure (parseKind kindText) + BindingObligation + <$> value .: "mappedName" + <*> value .: "package" + <*> value .: "module" + <*> value .: "symbol" + <*> pure kindValue + <*> value .: "signature" + <*> value .: "useSites" + <*> value .:? "bindingVersion" + +instance ToJSON BindingHole where + toJSON hole = + object + [ "schema" .= (1 :: Int) + , "mappedName" .= holeMappedName hole + , "module" .= holeModule hole + , "symbol" .= holeSymbol hole + , "kind" .= renderKind (holeKind hole) + , "path" .= holePath hole + , "signature" .= holeSignature hole + ] + +instance FromJSON BindingHole where + parseJSON = withObject "keiro-dsl binding hole" $ \value -> do + schema <- value .: "schema" + if schema /= (1 :: Int) + then fail "unsupported binding hole schema" + else do + kindText <- value .: "kind" + kindValue <- maybe (fail "unknown binding hole kind") pure (parseKind kindText) + BindingHole + <$> value .: "mappedName" + <*> value .: "module" + <*> value .: "symbol" + <*> pure kindValue + <*> value .:? "path" + <*> value .: "signature" + +bindingObligations :: Spec -> Either (NonEmpty TypeGraphError) [BindingObligation] +bindingObligations spec = do + graph <- resolveTypeGraph spec + pure . sortOn obligationSortKey . concat $ + [ obligationsFor graph declaration + | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph) + ] + +bindingHoles :: Spec -> Either (NonEmpty TypeGraphError) [BindingHole] +bindingHoles spec = do + graph <- resolveTypeGraph spec + obligations <- bindingObligations spec + pure . sortOn holeSortKey . concat $ + [ holesFor graph declaration shape obligations + | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) + ] + +holesFor :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [BindingObligation] -> [BindingHole] +holesFor _graph declaration shape obligations = bindingEntries <> auxiliaryEntries + where + own = filter ((== sdName declaration) . obligationMappedName) obligations + binding = onlyKind BindingValue + bindingEntries = case binding of + Nothing -> [] + Just obligation -> map (bindingHole obligation) (shapeHolePaths shape) + auxiliaryEntries = + [ BindingHole + { holeMappedName = obligationMappedName obligation + , holeModule = obligationModule obligation + , holeSymbol = obligationSymbol obligation + , holeKind = obligationKind obligation + , holePath = Nothing + , holeSignature = obligationSignature obligation + } + | obligation <- own + , obligationKind obligation /= BindingValue + ] + onlyKind wanted = case filter ((== wanted) . obligationKind) own of + entry : _ -> Just entry + [] -> Nothing + bindingHole obligation (path, expectedType) = + BindingHole + { holeMappedName = obligationMappedName obligation + , holeModule = obligationModule obligation + , holeSymbol = obligationSymbol obligation + , holeKind = BindingValue + , holePath = Just path + , holeSignature = obligationSymbol obligation <> "." <> path <> " :: " <> expectedType + } + +shapeHolePaths :: ResolvedMappedShape -> [(Text, Text)] +shapeHolePaths = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> [(rwfHaskell field, renderExprType (rwfType field)) | field <- fields] + , onEnum = \entries -> [(weCtor entry, "constructor case") | entry <- entries] + , onUnion = \_ arms -> + [ (rwaCtor arm, maybe "constructor case" renderExprType (rwaPayload arm)) + | arm <- arms + ] + } + +renderExprType :: ResolvedTypeExpr -> Text +renderExprType = + foldTypeExpr + TypeExprAlgebra + { onText = "Text" + , onInt = "Int" + , onBool = "Bool" + , onNatural = "Natural" + , onTime = "UTCTime" + , onJson = "Value" + , onOptional = \value -> "Maybe (" <> value <> ")" + , onList = \value -> "[" <> value <> "]" + , onMap = \value -> "Map Text (" <> value <> ")" + , onRef = unMappedKey + } + +obligationsFor :: TypeGraph -> StructuralDecl -> [BindingObligation] +obligationsFor graph declaration = bindingEntry : fixtureEntry : initialEntries + where + source = sdHaskell declaration + consumerType = hsModule source <> "." <> hsType source + shapeType = sdName declaration <> "Shape" + paths = map renderUsePath (usePaths graph (sdName declaration)) + registerPaths = + [ renderUsePath path + | path@UsePath{upRoot = RootRegister{}} <- usePaths graph (sdName declaration) + ] + bindingEntry = + obligationFor + declaration + (sdBinding declaration) + BindingValue + ("StructuralBinding " <> consumerType <> " " <> shapeType) + paths + (Just (unBindingVersion (sdBindingVersion declaration))) + fixtureEntry = + obligationFor + declaration + (sdFixtures declaration) + FixtureValue + ("FixtureCases " <> consumerType) + paths + Nothing + initialEntries = case (registerPaths, sdInitial declaration) of + ([], _) -> [] + (_, Nothing) -> [] + (_, Just initialValue) -> + [ obligationFor declaration initialValue InitialValue consumerType registerPaths Nothing + ] + +obligationFor :: StructuralDecl -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> BindingObligation +obligationFor declaration qualified kindValue signature paths version = + BindingObligation + { obligationMappedName = sdName declaration + , obligationPackage = hsPackage (sdHaskell declaration) + , obligationModule = ownerModule + , obligationSymbol = symbol + , obligationKind = kindValue + , obligationSignature = symbol <> " :: " <> signature + , obligationUseSites = paths + , obligationBindingVersion = version + } + where + (ownerModule, symbol) = splitQualified (unQualifiedValueName qualified) + +renderBindingObligations :: Text -> [BindingObligation] -> Text +renderBindingObligations context obligations = case obligations of + [] -> "no binding obligations for context " <> context + _ -> + T.unlines $ + ["binding obligations for context " <> context] + <> concatMap renderGroup grouped + where + grouped = groupBy sameOwner (sortOn obligationSortKey obligations) + sameOwner left right = ownerKey left == ownerKey right + renderGroup [] = [] + renderGroup entries@(first : _) = + (" " <> obligationModule first <> " (package " <> obligationPackage first <> ")") + : concatMap renderEntry entries + renderEntry obligation = + [ " " <> obligationSignature obligation + , " reason: " <> renderKind (obligationKind obligation) <> " — structural mapped type " <> obligationMappedName obligation <> renderPaths (obligationUseSites obligation) + ] + <> maybe [] (\version -> [" provenance: binding-version " <> quoted version]) (obligationBindingVersion obligation) + renderPaths [] = " (not currently used by an aggregate root)" + renderPaths paths = " (" <> T.intercalate "; " paths <> ")" + quoted value = T.pack (show value) + +obligationSortKey :: BindingObligation -> (Text, Text, Text, BindingObligationKind, Text) +obligationSortKey obligation = + ( obligationPackage obligation + , obligationModule obligation + , obligationMappedName obligation + , obligationKind obligation + , obligationSymbol obligation + ) + +ownerKey :: BindingObligation -> (Text, Text) +ownerKey obligation = (obligationPackage obligation, obligationModule obligation) + +holeSortKey :: BindingHole -> (Text, Name, BindingObligationKind, Maybe Text, Text) +holeSortKey hole = + (holeModule hole, holeMappedName hole, holeKind hole, holePath hole, holeSymbol hole) + +renderKind :: BindingObligationKind -> Text +renderKind BindingValue = "binding" +renderKind FixtureValue = "fixtures" +renderKind InitialValue = "initial-value" + +parseKind :: Text -> Maybe BindingObligationKind +parseKind "binding" = Just BindingValue +parseKind "fixtures" = Just FixtureValue +parseKind "initial-value" = Just InitialValue +parseKind _ = Nothing + +splitQualified :: Text -> (Text, Text) +splitQualified value = + let (prefix, name) = T.breakOnEnd "." value + in (T.dropEnd 1 prefix, name) diff --git a/src/Keiro/Dsl/FoldFingerprint.hs b/src/Keiro/Dsl/FoldFingerprint.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/FoldFingerprint.hs @@ -0,0 +1,167 @@ +{- | Canonical identities for the aggregate fold surface used while hydrating +event streams. The fingerprint deliberately excludes payload codecs, +projections, snapshot policy, and source locations: those inputs do not change +how an existing event log becomes aggregate state. +-} +module Keiro.Dsl.FoldFingerprint ( + aggregateFoldFingerprint, + aggregateFoldSurface, +) where + +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar +import Keiro.Dsl.PrettyPrint (renderExpr) +import Keiro.Dsl.ReadModelShape (fnv1a64) +import Keiro.Dsl.TypeGraph + +-- | The sixteen-hex-digit identity of an aggregate's replay fold. +aggregateFoldFingerprint :: Spec -> Aggregate -> Text +aggregateFoldFingerprint spec = fnv1a64 . aggregateFoldSurface spec + +{- | Canonical pre-hash text for an aggregate's replay fold. + +Rules are declarations on 'Spec', not children of 'Aggregate', so the complete +spec is required. Only rules reached from transition guards and writes are +included, transitively, in declaration order. +-} +aggregateFoldSurface :: Spec -> Aggregate -> Text +aggregateFoldSurface spec aggregate = + T.intercalate + "\n" + ( map stateSegment (aggStates aggregate) + ++ map registerSegment (aggRegs aggregate) + ++ mappedRegisterSegments + ++ map transitionSegment (aggTransitions aggregate) + ++ map ruleSegment referencedRules + ) + where + referencedRules = + [ rule + | rule <- specRules spec + , ruleName rule `Set.member` referencedRuleNames spec aggregate + ] + mappedRegisterSegments = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> + [ mappedRegisterSegment graph declaration + | register <- aggRegs aggregate + , Just declaration <- [Map.lookup (MappedKey (regType register)) (tgDeclarations graph)] + ] + +mappedRegisterSegment :: TypeGraph -> ResolvedMappedDecl -> Text +mappedRegisterSegment graph (ResolvedStructural declaration _) = + T.intercalate + "|" + [ "mapped-register:" <> sdName declaration + , "wire=" <> wireFingerprint graph (sdName declaration) + , "canonical=" <> unCanonicalTypeId (sdCanonical declaration) + , "binding=" <> unQualifiedValueName (sdBinding declaration) + , "binding-version=" <> unBindingVersion (sdBindingVersion declaration) + , "initial=" <> maybe "(missing)" unQualifiedValueName (sdInitial declaration) + ] +mappedRegisterSegment _ (ResolvedOpaque declaration) = + T.intercalate + "|" + [ "mapped-register:" <> odName declaration + , "codec=" <> unCodecIdentity (odCodecIdentity declaration) + , "codec-version=" <> unCodecVersion (odCodecVersion declaration) + , "initial=" <> maybe "(missing)" unQualifiedValueName (odInitial declaration) + ] + +stateSegment :: StateDecl -> Text +stateSegment state = + "state:" + <> stName state + <> "|terminal=" + <> if stTerminal state then "true" else "false" + +registerSegment :: RegDecl -> Text +registerSegment register = + "reg:" + <> regName register + <> ":" + <> regType register + <> "=" + <> renderInitial (regInitial register) + +renderInitial :: RegInitial -> Text +renderInitial (RegInitBare value) = value +renderInitial (RegInitText value) = "\"" <> escapeText value <> "\"" + +escapeText :: Text -> Text +escapeText = T.concatMap $ \case + '"' -> "\\\"" + '\\' -> "\\\\" + '\n' -> "\\n" + '\t' -> "\\t" + '\r' -> "\\r" + character -> T.singleton character + +transitionSegment :: Transition -> Text +transitionSegment transition = + T.intercalate + "|" + [ "transition:" <> renderMode (tMode transition) + , tSource transition + , tCommand transition + , "guard=" <> maybe "" renderExpr (tGuard transition) + , "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition)) + , "emits=" <> T.intercalate "," (tEmits transition) + , "goto=" <> tGoto transition + ] + where + renderWrite (registerName, expression) = registerName <> ":=" <> renderExpr expression + +renderMode :: TransitionMode -> Text +renderMode TmLive = "live" +renderMode TmReplayOnly = "replay-only" + +ruleSegment :: RuleDecl -> Text +ruleSegment rule = + T.intercalate + "|" + [ "rule:" <> ruleName rule + , ruleDomain rule + , ruleCodomain rule + , "cases=" <> T.intercalate ";" (map renderCase (ruleCases rule)) + ] + where + renderCase (constructorName, expression) = constructorName <> "=>" <> renderExpr expression + +referencedRuleNames :: Spec -> Aggregate -> Set Name +referencedRuleNames spec aggregate = close directNames + where + rules = specRules spec + directNames = + Set.unions + [ exprNames expression + | transition <- aggTransitions aggregate + , expression <- maybeToList (tGuard transition) ++ map snd (tWrites transition) + ] + close names = + let expanded = + Set.unions + ( names + : [ Set.unions (map (exprNames . snd) (ruleCases rule)) + | name <- Set.toList names + , Just rule <- [find ((== name) . ruleName) rules] + ] + ) + in if expanded == names then names else close expanded + +exprNames :: Expr -> Set Name +exprNames = \case + EOr left right -> exprNames left <> exprNames right + EAnd left right -> exprNames left <> exprNames right + ECmp _ left right -> exprNames left <> exprNames right + EAtom (AName name) -> Set.singleton name + EAtom (ABool _) -> Set.empty + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just value) = [value] diff --git a/src/Keiro/Dsl/Goldens.hs b/src/Keiro/Dsl/Goldens.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Goldens.hs @@ -0,0 +1,228 @@ +{- | Versioned event-payload fixtures captured at spec-diff time. + +The current aggregate specification cannot reconstruct an older payload shape, +so golden payloads are synthesized while both the old and new specifications +are available. Existing files are never overwritten: a hand-captured +production payload is always more authoritative than a synthesized sample. +-} +module Keiro.Dsl.Goldens ( + GoldenEvidence (..), + GoldenPayload (..), + goldensForDiff, + emitGoldenPayloads, + loadGoldenPayloads, + goldenRelativePath, +) where + +import Data.Aeson (Value (..)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Text qualified as AesonText +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Keiro.Dsl.Grammar +import Keiro.Dsl.Scaffold (Agg (..), ResolvedCtor (..), defaultContext, resolveAgg) +import Keiro.Dsl.TypeGraph +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeFileName, ()) + +data GoldenEvidence = SynthesizedWeakStandIn | FileOwnedFixture + deriving stock (Eq, Show) + +data GoldenPayload = GoldenPayload + { goldenContext :: !Text + , goldenAggregate :: !Text + , goldenEvent :: !Text + , goldenVersion :: !Int + , goldenJson :: !Text + , goldenEvidence :: !GoldenEvidence + } + deriving stock (Eq, Show) + +{- | Synthesize one old-shape payload for each event whose version increases. +The result is deterministic and ordered like the old specification. +-} +goldensForDiff :: Spec -> Spec -> [GoldenPayload] +goldensForDiff oldSpec newSpec = + [ GoldenPayload + { goldenContext = specContext oldSpec + , goldenAggregate = aggName oldAggregate + , goldenEvent = evName oldEvent + , goldenVersion = evVersion oldEvent + , goldenJson = renderGolden oldSpec oldResolved oldResolvedEvent + , goldenEvidence = SynthesizedWeakStandIn + } + | oldAggregate <- aggregates oldSpec + , Just newAggregate <- [find ((== aggName oldAggregate) . aggName) (aggregates newSpec)] + , let oldResolved = resolveAgg (defaultContext (specContext oldSpec)) oldSpec oldAggregate + , oldEvent <- aggEvents oldAggregate + , Just newEvent <- [find ((== evName oldEvent) . evName) (aggEvents newAggregate)] + , evVersion newEvent > evVersion oldEvent + , Just oldResolvedEvent <- [find ((== evName oldEvent) . rcName) (aEvents oldResolved)] + ] + where + aggregates spec = [aggregate | NAggregate aggregate <- specNodes spec] + +{- | Write newly synthesized fixtures below +@///.v.json@. Existing files are +left untouched and omitted from the returned path list. +-} +emitGoldenPayloads :: FilePath -> Spec -> Spec -> IO [FilePath] +emitGoldenPayloads root oldSpec newSpec = + fmap concat . traverse writeIfMissing $ goldensForDiff oldSpec newSpec + where + writeIfMissing golden = do + let path = root goldenRelativePath golden + exists <- doesFileExist path + if exists + then pure [] + else do + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path (goldenJson golden) + pure [path] + +{- | Load only the fixtures relevant to declared upcasters in @spec@. +@root@ may name the global golden root or its context child directory. +-} +loadGoldenPayloads :: FilePath -> Spec -> IO [GoldenPayload] +loadGoldenPayloads root spec = do + contextRoot <- resolveContextRoot root (T.unpack (specContext spec)) + fmap concat . traverse (loadAggregate contextRoot) $ aggregates spec + where + aggregates current = [aggregate | NAggregate aggregate <- specNodes current] + + loadAggregate contextRoot aggregate = + fmap concat . traverse (loadEvent contextRoot aggregate) $ aggEvents aggregate + + loadEvent contextRoot aggregate event = case evUpcastFrom event of + Nothing -> pure [] + Just (sourceVersion, _) -> do + let golden = + GoldenPayload + { goldenContext = specContext spec + , goldenAggregate = aggName aggregate + , goldenEvent = evName event + , goldenVersion = sourceVersion + , goldenJson = "" + , goldenEvidence = FileOwnedFixture + } + path = contextRoot aggregateRelativePath golden + exists <- doesFileExist path + if exists + then do + contents <- TIO.readFile path + pure [golden{goldenJson = contents}] + else pure [] + +goldenRelativePath :: GoldenPayload -> FilePath +goldenRelativePath golden = + T.unpack (goldenContext golden) aggregateRelativePath golden + +aggregateRelativePath :: GoldenPayload -> FilePath +aggregateRelativePath golden = + T.unpack (goldenAggregate golden) + T.unpack (goldenEvent golden) + <> ".v" + <> show (goldenVersion golden) + <> ".json" + +resolveContextRoot :: FilePath -> FilePath -> IO FilePath +resolveContextRoot root contextName = do + let nested = root contextName + nestedExists <- doesDirectoryExist nested + pure $ + if nestedExists + then nested + else + if takeFileName (dropTrailingPathSeparator root) == contextName + then root + else nested + +renderGolden :: Spec -> Agg -> ResolvedCtor -> Text +renderGolden spec aggregate event = + TL.toStrict (AesonText.encodeToLazyText (Object (KeyMap.fromList entries))) <> "\n" + where + graph = either (const Nothing) Just (resolveTypeGraph spec) + entries = + (Key.fromText "kind", String (rcName event)) + : [(Key.fromText fieldName, sampleValue graph spec aggregate fieldType) | (fieldName, fieldType) <- rcFields event] + +sampleValue :: Maybe TypeGraph -> Spec -> Agg -> Text -> Value +sampleValue graph spec _aggregate fieldType + | Just identifier <- find ((== fieldType) . idName) (specIds spec) = + String (idPrefix identifier <> "_01hzy3v7q2e8kaw2m5x0d41n9c") + | Just enum <- find ((== fieldType) . enumName) (specEnums spec) + , (_, wireValue) : _ <- enumCtors enum = + String wireValue + | Just resolved <- graph + , Just declaration <- Map.lookup (MappedKey fieldType) (tgDeclarations resolved) = + sampleMappedDeclaration resolved declaration + | fieldType == "Int" = Number 1 + | fieldType == "Bool" = Bool True + | fieldType `elem` ["Time", "UTCTime"] = String "2026-01-01T00:00:00Z" + | otherwise = String "sample" + +sampleMappedDeclaration :: TypeGraph -> ResolvedMappedDecl -> Value +sampleMappedDeclaration graph = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ -> sampleMappedShape graph + , onOpaqueDecl = const emptyObject + } + +sampleMappedShape :: TypeGraph -> ResolvedMappedShape -> Value +sampleMappedShape graph = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + Object . KeyMap.fromList $ + [ (Key.fromText (rwfKey field), sampleMappedExpression graph (rwfType field)) + | field <- fields + , includeField field + ] + , onEnum = \entries -> case entries of + firstEntry : _ -> String (weTag firstEntry) + [] -> String "sample" + , onUnion = \encoding arms -> case arms of + firstArm : _ -> + Object . KeyMap.fromList $ + [(Key.fromText (ueTagField encoding), String (rwaTag firstArm))] + <> [ (Key.fromText (ueContentsField encoding), sampleMappedExpression graph payload) + | payload <- maybeToList (rwaPayload firstArm) + ] + [] -> emptyObject + } + where + includeField field = case rwfPresence field of + PRequired -> True + POptional -> isNothingValue (rwfOnMissing field) + +sampleMappedExpression :: TypeGraph -> ResolvedTypeExpr -> Value +sampleMappedExpression graph = + foldTypeExpr + TypeExprAlgebra + { onText = String "sample" + , onInt = Number 1 + , onBool = Bool True + , onNatural = Number 1 + , onTime = String "2026-01-01T00:00:00Z" + , onJson = emptyObject + , onOptional = id + , onList = \value -> Array (pure value) + , onMap = \value -> Object (KeyMap.singleton (Key.fromText "sample") value) + , onRef = \key -> maybe emptyObject (sampleMappedDeclaration graph) (Map.lookup key (tgDeclarations graph)) + } + +emptyObject :: Value +emptyObject = Object KeyMap.empty + +maybeToList :: Maybe a -> [a] +maybeToList = maybe [] pure + +isNothingValue :: Maybe a -> Bool +isNothingValue Nothing = True +isNothingValue Just{} = False diff --git a/src/Keiro/Dsl/Grammar.hs b/src/Keiro/Dsl/Grammar.hs --- a/src/Keiro/Dsl/Grammar.hs +++ b/src/Keiro/Dsl/Grammar.hs @@ -15,6 +15,20 @@ EnumDecl (..), RuleDecl (..), + -- * Consumer-owned mapped types (EP-149) + TypeExpr (..), + Presence (..), + UnknownFields (..), + OnMissing (..), + WireField (..), + wireFieldLoc, + UnionEncoding (..), + WireEnum (..), + WireArm (..), + MappedShape (..), + HaskellSource (..), + MappedDecl (..), + -- * The eight hole-kind types Derivation (..), DerivStrategy (..), @@ -28,6 +42,7 @@ Expr (..), CmpOp (..), Atom (..), + complementExpr, -- * The aggregate node RegInitial (..), @@ -39,6 +54,7 @@ EventBody (..), Hole (..), Transition (..), + TransitionMode (..), WireSpec (..), ProjectionSpec (..), Consistency (..), @@ -112,6 +128,7 @@ -- * The workflow/operation nodes (EP-6) WfBodyItem (..), WorkflowNode (..), + workflowNodeLoc, OperationShape (..), OperationNode (..), @@ -179,6 +196,111 @@ } deriving stock (Eq, Show, Generic) +-- Consumer-owned mapped types (EP-149). The parser-facing declarations keep +-- required facts optional so `keiro-dsl check` can report stable, located +-- diagnostics for omissions. Keiro.Dsl.TypeGraph turns valid values into a +-- checked representation before downstream consumers inspect them. + +data TypeExpr + = TText + | TInt + | TBool + | TNatural + | TTime + | TJson + | TOptional !TypeExpr + | TList !TypeExpr + | TMap !TypeExpr + | TRef !Name + deriving stock (Eq, Show, Generic) + +data Presence = PRequired | POptional + deriving stock (Eq, Show, Generic) + +data UnknownFields = RejectUnknown | IgnoreUnknown + deriving stock (Eq, Show, Generic) + +data OnMissing + = OmNull + | OmText !Text + | OmInt !Integer + | OmBool !Bool + | OmEmptyList + | OmEmptyMap + | OmCtor !Name + deriving stock (Eq, Show, Generic) + +data WireField = WireField + { wfHaskell :: !Name + , wfKey :: !Text + , wfType :: !TypeExpr + , wfPresence :: !Presence + , wfOnMissing :: !(Maybe OnMissing) + , wfLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +wireFieldLoc :: WireField -> Loc +wireFieldLoc WireField{wfLoc = loc} = loc + +data UnionEncoding = TaggedObject + { ueTagField :: !Text + , ueContentsField :: !Text + , ueUnknownFields :: !UnknownFields + } + deriving stock (Eq, Show, Generic) + +data WireEnum = WireEnum + { weCtor :: !Name + , weTag :: !Text + , weLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data WireArm = WireArm + { waCtor :: !Name + , waTag :: !Text + , waPayload :: !(Maybe TypeExpr) + , waLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data MappedShape + = ShapeRecord !Name !UnknownFields ![WireField] + | ShapeEnum ![WireEnum] + | ShapeUnion !UnionEncoding ![WireArm] + deriving stock (Eq, Show, Generic) + +data HaskellSource = HaskellSource + { hsPackage :: !Text + , hsModule :: !Text + , hsType :: !Name + } + deriving stock (Eq, Show, Generic) + +data MappedDecl + = MappedStructural + { msName :: !Name + , msHaskell :: !(Maybe HaskellSource) + , msBinding :: !(Maybe Text) + , msBindingVersion :: !(Maybe Text) + , msCanonical :: !(Maybe Text) + , msFixtures :: !(Maybe Text) + , msInitial :: !(Maybe Text) + , msShape :: !MappedShape + , msLoc :: !Loc + } + | MappedOpaque + { moName :: !Name + , moHaskell :: !(Maybe HaskellSource) + , moCodecId :: !(Maybe Text) + , moCodecVersion :: !(Maybe Text) + , moFixtures :: !(Maybe Text) + , moInitial :: !(Maybe Text) + , moLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + -- The eight hole-kind types. EP-1 only exercises hole-kinds 1–3 against the -- aggregate vertical; the rest exist so EP-3…EP-6 reuse the same types. @@ -257,6 +379,33 @@ | ABool !Bool deriving stock (Eq, Show, Generic) +{- | The logical complement of a guard, expressed inside the existing grammar — +'Expr' has no negation constructor, but negation is eliminable: De Morgan over +'EOr'\/'EAnd', comparison-operator flipping, boolean-literal flip, and +@x == false@ for a bare name atom (guards are boolean-valued, so a bare name +in guard position is a boolean read). Used by @diff@ to compute the +replay-only twin of a tightened guard (@old ∧ ¬new@, plan 143): the printed +complement re-parses as a valid guard today. + +Caveat: comparison flipping is classical — @¬(a < b) = a >= b@ — which is +correct over the DSL's total ordered domains. +-} +complementExpr :: Expr -> Expr +complementExpr = \case + EOr l r -> EAnd (complementExpr l) (complementExpr r) + EAnd l r -> EOr (complementExpr l) (complementExpr r) + ECmp op l r -> ECmp (complementCmp op) l r + EAtom (ABool b) -> EAtom (ABool (not b)) + e@(EAtom (AName _)) -> ECmp OpEq e (EAtom (ABool False)) + where + complementCmp = \case + OpEq -> OpNeq + OpNeq -> OpEq + OpLt -> OpGe + OpLe -> OpGt + OpGt -> OpLe + OpGe -> OpLt + {- | @name Type = initial@ — a named register with its declared type and the initial value (an identifier: a literal like @placeholder@, an enum constructor, or a state name). @@ -303,10 +452,10 @@ deriving stock (Eq, Show, Generic) {- | @event Name { … }@ or @event Name = fields(Command)@. EP-2 (evolution) adds -the version/upcaster/deprecation fields: an unversioned event is @evVersion = 1@, -@evUpcastFrom = Nothing@, @evDeprecated = False@, reproducing the EP-1 surface. -These fields live on the shared 'Event' so every node family's events inherit -schema-versioning for free. +the version/upcaster/retirement fields: an unversioned event is @evVersion = 1@, +@evUpcastFrom = Nothing@, @evRetiring = False@, and @evDeprecated = False@, +reproducing the EP-1 surface. These fields live on the shared 'Event' so every +node family's events inherit schema-versioning for free. -} data Event = Event { evName :: !Name @@ -317,9 +466,16 @@ {- ^ The source version this shape migrates /from/, paired with the upcaster hole. @Just (n-1, …)@ for a @vN@ shape; 'Nothing' for v1. -} + , evRetiring :: !Bool + {- ^ Retirement is in progress. The event must keep at least one live + emitting transition while operators terminalize or truncate affected + streams; cut over to @deprecated@ plus a replay-only emitting transition + afterwards. + -} , evDeprecated :: !Bool - {- ^ Retired from the write path (no transition may @emit@ it) but still - decodable from the log. + {- ^ Retired from the write path (no live transition may @emit@ it) but + still decodable from the log. A replay-only emitting transition must remain + while live streams can still contain the event. -} , evLoc :: !Loc } @@ -346,10 +502,23 @@ , tWrites :: ![(Name, Expr)] , tEmits :: ![Name] , tGoto :: !Name + , tMode :: !TransitionMode , tLoc :: !Loc } deriving stock (Eq, Show, Generic) +{- | Whether a transition serves forward execution or replay only (plan 143). +A @replay-only@ transition lowers to a keiki 'ReplayOnly' edge: it is never +taken by a new command and exists so events emitted under a retired rule keep +an inverting edge. Spelled as a @replay-only@ prefix on the transition line: + +@ +replay-only Held -- ConfirmReservation --> guard … ; emit … ; goto … +@ +-} +data TransitionMode = TmLive | TmReplayOnly + deriving stock (Eq, Show, Generic) + {- | @wire kind=ctorName fields=camelCase schemaVersion=1@ — how events serialize. -} @@ -927,6 +1096,9 @@ } deriving stock (Eq, Show, Generic) +workflowNodeLoc :: WorkflowNode -> Loc +workflowNodeLoc WorkflowNode{wfLoc = loc} = loc + -- | The four operation shapes. data OperationShape = -- | @command on stream from via project [ … ]@ @@ -981,7 +1153,7 @@ deriving stock (Eq, Show, Generic) {- | A whole @.keiro@ file: one context name, an optional module-placement -override (the @module@/@layout@ clauses), the shared id/enum/rule declarations, +override (the @module@/@layout@ clauses), the shared id/enum/rule/mapped declarations, and the list of nodes. 'specModuleRoot' and 'specLayout' are 'Nothing' when the spec omits the clauses, reproducing the historical default. -} @@ -992,6 +1164,7 @@ , specIds :: ![IdDecl] , specEnums :: ![EnumDecl] , specRules :: ![RuleDecl] + , specMapped :: ![MappedDecl] , specNodes :: ![Node] } deriving stock (Eq, Show, Generic) diff --git a/src/Keiro/Dsl/Harness.hs b/src/Keiro/Dsl/Harness.hs --- a/src/Keiro/Dsl/Harness.hs +++ b/src/Keiro/Dsl/Harness.hs @@ -14,35 +14,60 @@ stepping a sample command lands on the declared @goto@ vertex. This is the check a wrong guard fails — flipping @./=@ to @.==@ in the filled body turns it red while leaving the scaffold untouched. + 5. a forward/replay equality check per live, event-emitting transition out of + the initial state: emitted events cross the generated codec boundary, then + replay must reconstruct the forward vertex and every declared register. + +@Text@ samples include their field name so same-typed field swaps remain visible +to the replay check. Other sample kinds remain uniform until fixture bindings can +supply a wider, consumer-owned corpus. -} module Keiro.Dsl.Harness ( harnessFor, + harnessForWithGoldens, harnessProcess, harnessRouter, harnessReadModel, harnessWorkflow, ) where +import Data.List (find) +import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T +import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor) import Keiro.Dsl.Scaffold +import Keiro.Dsl.TypeGraph {- | Emit the harness test module for one aggregate. Like 'scaffoldAggregate', it takes the 'Spec' for the shared id\/enum declarations. -} harnessFor :: Context -> Spec -> Aggregate -> [ScaffoldModule] -harnessFor ctx spec agg = +harnessFor = harnessForWithGoldens [] + +{- | Emit an aggregate harness with checked-in old-payload fixtures embedded +as string literals. Embedding keeps the generated test independent of runtime +file paths while retaining the golden file as regeneration source of truth. +-} +harnessForWithGoldens :: [GoldenPayload] -> Context -> Spec -> Aggregate -> [ScaffoldModule] +harnessForWithGoldens goldens ctx spec agg = [ ScaffoldModule { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/Harness.hs") - , moduleText = emitHarness a + , moduleText = emitHarness relevantGoldens a , kind = Generated , origin = "aggregate " <> aggName agg <> locSuffix (aggLoc agg) } ] where a = resolveAgg ctx spec agg + relevantGoldens = + [ golden + | golden <- goldens + , goldenContext golden == specContext spec + , goldenAggregate golden == aggName agg + ] {- | Emit a self-contained, firewall-clean facts harness for a process manager, pinning the spec's deterministic decisions: the time-injection formula, the @@ -239,13 +264,13 @@ { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowFacts.hs") , moduleText = emitWorkflowFacts genPrefix w , kind = Generated - , origin = "workflow " <> wfId w <> locSuffix (wfLoc w) + , origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w) } , ScaffoldModule { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowRuntime.hs") , moduleText = emitWorkflowRuntime genPrefix w , kind = Generated - , origin = "workflow " <> wfId w <> locSuffix (wfLoc w) + , origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w) } ] where @@ -351,75 +376,141 @@ go (WfPatch patchId items _) = patchId : workflowPatchIds items go _ = [] -emitHarness :: Agg -> Text -emitHarness a = +emitHarness :: [GoldenPayload] -> Agg -> Text +emitHarness goldens a = nl $ - [ "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where" - , "" - , "import " <> aGenPrefix a <> ".Domain" - , "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> ")" - , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst nm <> "Transducer)" - , "import Keiki.Core (defaultValidationOptions, step, validateTransducer)" - , codecDecodeRawImport - , "" - , "{- | (label, passed). A driver runs these and exits non-zero on any False," - , "naming the failing assertion. Filling a hole wrongly turns a specific" - , "entry False; the scaffold cannot." - , "-}" - , "harnessAssertions :: [(String, Bool)]" - , "harnessAssertions =" - , " [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))" - , " , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")" + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE OverloadedLabels #-}" + , "{-# LANGUAGE OverloadedStrings #-}" ] + ++ ["{-# LANGUAGE TypeApplications #-}" | hasMappedHarness a] + ++ [ generatedBanner + , "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where" + , "" + , "import " <> aGenPrefix a <> ".Domain" + , "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")" + , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst nm <> "Transducer)" + , "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")" + , codecDecodeRawImport + ] + ++ mappedHarnessImports a + ++ goldenImports + ++ [ "" + , "{- | (label, passed). A driver runs these and exits non-zero on any False," + , "naming the failing assertion. Filling a hole wrongly turns a specific" + , "entry False; the scaffold cannot." + , "-}" + , "harnessAssertions :: [(String, Bool)]" + , "harnessAssertions =" + , " [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))" + , " , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")" + ] ++ [ " , (\"golden round-trip: " <> rcName e <> "\", roundTrips sampleEvent" <> rcName e <> ")" | e <- aEvents a ] ++ [ " , (\"accepts " <> tCommand t <> " from " <> initialVertex a <> "\", accept" <> tCommand t <> ")" | t <- initialTransitions a ] - ++ [ " , (\"upcaster wired: a v" <> tInt m <> " " <> rcName e <> " payload decodes through the chain\", upcasts" <> rcName e <> ")" - | e <- upcastEvents - , Just m <- [rcUpcastFrom e] - ] ++ [ " ]" - , "" + ] + ++ [" ++ mappedConformanceAssertions" | hasMappedHarness a] + ++ [ " ++ forwardReplay" <> tCommand t + | t <- replayTransitions + ] + ++ ( if null upcastEvents + then [] + else + [ " ++ [ " <> T.intercalate "\n , " upcastAssertions + , " ]" + ] + ) + ++ [ "" , "roundTrips :: " <> nm <> "Event -> Bool" , "roundTrips e = parse" <> nm <> "Event (eventType " <> lowerFirst nm <> "Codec e) (encode" <> nm <> "Event e) == Right e" ] ++ concatMap (sampleEventDecl a) (aEvents a) ++ concatMap (acceptDecl a) (initialTransitions a) - ++ concatMap (upcastDecl a) upcastEvents + ++ concatMap (forwardReplayDecl a) replayTransitions + ++ concatMap (upcastDecl goldens a) upcastEvents + ++ mappedHarnessDeclarations a where nm = aName a -- Bake the clock-free result computed from the spec at scaffold time. clockFreeLit = if specIsClockFree a then "True" else "False" upcastEvents = [e | e <- aEvents a, rcUpcastFrom e /= Nothing] + replayTransitions = + [ t + | t <- initialTransitions a + , tMode t == TmLive + , not (null (tEmits t)) + ] + coreImports = + ["applyEventsEither" | not (null replayTransitions)] + ++ ["defaultValidationOptions", "step", "validateTransducer"] + ++ ["fieldWitnessAgrees" | not (null (mappedProjectionSpecs a))] + ++ ["(!)" | not (null replayTransitions) && not (null (aRegs a))] + upcastAssertions = + [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> rcName e <> ")" + | e <- upcastEvents + , Just m <- [rcUpcastFrom e] + ] codecValueImport = ", " <> lowerFirst nm <> "Codec" codecDecodeRawImport = if null upcastEvents then "import Keiro.Codec (eventType)" else "import Keiro.Codec (EventType (..), decodeRaw, eventType)" + goldenImports = + if any (hasGolden goldens) upcastEvents + then + [ "import Data.Aeson (eitherDecodeStrict)" + , "import Data.Text.Encoding (encodeUtf8)" + ] + else [] + upcastLabel event source = + case goldenFor goldens event of + Just _ -> "golden " <> rcName event <> ".v" <> tInt source <> " decodes" + Nothing -> + "upcast " + <> rcName event + <> " chain wired (current-shape stand-in; add a golden payload)" -{- | A wiring-proof assertion: feed a current-shape payload tagged at the -upcaster's source version through @decodeRaw@, which runs the upcaster chain -then @decode@. Red while the upcaster hole returns @Left@; green once filled. -(The grammar records only the current event shape, not the per-version field -delta, so this proves the chain is wired and the hole must be filled rather -than re-deriving the exact old payload.) +{- | Decode a genuine embedded old payload when available. Without a golden, +retain the weaker current-shape wiring assertion and label it honestly. -} -upcastDecl :: Agg -> ResolvedCtor -> [Text] -upcastDecl a e = case rcUpcastFrom e of +upcastDecl :: [GoldenPayload] -> Agg -> ResolvedCtor -> [Text] +upcastDecl goldens a e = case rcUpcastFrom e of Nothing -> [] - Just m -> - [ "" - , "upcasts" <> rcName e <> " :: Bool" - , "upcasts" <> rcName e <> " =" - , " either (const False) (const True)" - , " (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))" - ] + Just m -> case goldenFor goldens e of + Just golden -> + [ "" + , "upcasts" <> rcName e <> " :: Bool" + , "upcasts" <> rcName e <> " =" + , " case eitherDecodeStrict (encodeUtf8 " <> tshow (goldenJson golden) <> ") of" + , " Left _ -> False" + , " Right payload ->" + , " either (const False) (const True)" + , " (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " payload)" + ] + Nothing -> + [ "" + , "upcasts" <> rcName e <> " :: Bool" + , "upcasts" <> rcName e <> " =" + , " either (const False) (const True)" + , " (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))" + ] +hasGolden :: [GoldenPayload] -> ResolvedCtor -> Bool +hasGolden goldens event = case goldenFor goldens event of + Just _ -> True + Nothing -> False + +goldenFor :: [GoldenPayload] -> ResolvedCtor -> Maybe GoldenPayload +goldenFor goldens event = do + source <- rcUpcastFrom event + find + (\golden -> goldenEvent golden == rcName event && goldenVersion golden == source) + goldens + tInt :: Int -> Text tInt = T.pack . show @@ -451,7 +542,8 @@ [] -> [] {- | @sampleEvent :: Event@ — a sample built from per-field sample -values (enum→first constructor, Bool→False, id→placeholder, Text→\"sample\"). +values (enum→first constructor, Bool→False, id→placeholder, +Text→\"sample-\"). -} sampleEventDecl :: Agg -> ResolvedCtor -> [Text] sampleEventDecl a e = @@ -474,20 +566,515 @@ (c : _) -> "(" <> ctorExpr a c <> ")" [] -> "(error \"no command\")" +forwardReplayDecl :: Agg -> Transition -> [Text] +forwardReplayDecl a t = + [ "" + , "-- forward/replay equality (plan 147): cross the persisted codec boundary," + , "-- replay the emitted chain, and compare the final vertex and every register." + , helperName <> " :: [(String, Bool)]" + , helperName <> " =" + , " case step " <> transducer <> " (" <> initial <> ", " <> initialRegs <> ") " <> cmdSample <> " of" + , " Nothing -> [(prefix <> \"forward step accepted\", False)]" + , " Just (forwardVertex, " <> forwardRegsName <> ", emitted) ->" + , " case mapM (\\event -> parse" <> nm <> "Event (eventType " <> codec <> " event) (encode" <> nm <> "Event event)) emitted of" + , " Left _ -> [(prefix <> \"emitted chain decodes\", False)]" + , " Right decodedEvents ->" + , " case applyEventsEither " <> transducer <> " (" <> initial <> ", " <> initialRegs <> ") decodedEvents of" + , " Left _ -> [(prefix <> \"replay succeeds\", False)]" + , " Right (replayVertex, " <> replayRegsName <> ") ->" + , " [ (prefix <> \"final vertex\", replayVertex == forwardVertex)" + ] + ++ [ " , (prefix <> \"register " <> regName reg <> "\", (replayRegs ! #" <> regName reg <> ") == (forwardRegs ! #" <> regName reg <> "))" + | reg <- aRegs a + ] + ++ [ " ]" + , " where" + , " prefix = \"forward/replay equality: " <> tCommand t <> " from " <> initial <> " -- \"" + ] + where + nm = aName a + helperName = "forwardReplay" <> tCommand t + transducer = lowerFirst nm <> "Transducer" + codec = lowerFirst nm <> "Codec" + initial = initialVertex a + initialRegs = "initial" <> nm <> "Regs" + forwardRegsName = if null (aRegs a) then "_forwardRegs" else "forwardRegs" + replayRegsName = if null (aRegs a) then "_replayRegs" else "replayRegs" + cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of + (c : _) -> "(" <> ctorExpr a c <> ")" + [] -> "(error \"no command\")" + -- | @( (Data v1 v2 …))@ with positional sample field values. ctorExpr :: Agg -> ResolvedCtor -> Text ctorExpr a rc = "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))" where - args = T.concat [" " <> sampleValue a ty | (_, ty) <- rcFields rc] + args = T.concat [" " <> sampleValue a fieldName ty | (fieldName, ty) <- rcFields rc] -sampleValue :: Agg -> Text -> Text -sampleValue a ty = case fieldCat a ty of +sampleValue :: Agg -> Text -> Text -> Text +sampleValue a fieldName ty = case fieldCat a ty of IdCat -> "(" <> ty <> " \"sample\")" EnumCat -> maybe ("(error \"no enum ctor\")") id (firstEnumCtor a ty) + MappedStructuralCat declaration _ -> fixtureSample (sdFixtures declaration) + MappedOpaqueCat declaration -> fixtureSample (odFixtures declaration) OtherCat | ty == "Bool" -> "False" | ty == "Int" -> "0" - | ty == "Text" -> "\"sample\"" + | ty == "Text" -> tshow ("sample-" <> fieldName) | ty == aVertexType a -> initialVertex a | otherwise -> "(error \"sample: unsupported type " <> ty <> "\")" + +mappedHarnessImports :: Agg -> [Text] +mappedHarnessImports aggregate + | null fixtures = [] + | otherwise = + [ "import Data.Aeson qualified as Aeson" + , "import Data.Aeson.Key qualified as AesonKey" + , "import Data.Aeson.KeyMap qualified as AesonKeyMap" + , "import Data.Either (isLeft, isRight)" + , "import Data.List (nub)" + , "import Data.List.NonEmpty qualified as NonEmpty" + , "import Data.Maybe (isJust, isNothing)" + , "import Data.Proxy (Proxy (..))" + , "import Data.Text qualified as T" + , "import Keiki.Shape (CanonicalTypeName (..))" + , "import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)" + ] + ++ map (\moduleName -> "import " <> moduleName <> " qualified") (unique (modules <> bindingModules <> shapeModules <> consumerModules)) + ++ ["import " <> structuralProjectionModuleName (aContext aggregate) <> " qualified as StructuralProjections" | not (null (mappedProjectionSpecs aggregate))] + where + fixtures = [mappedFixtures declaration | declaration <- mappedHarnessDeclarationsResolved aggregate] + modules = unique [fst (splitQualifiedHarness (unQualifiedValueName qualified)) | qualified <- fixtures] + bindingModules = + [ fst (splitQualifiedHarness (unQualifiedValueName (sdBinding declaration))) + | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate + ] + shapeModules = + [ structuralShapeModuleName (aContext aggregate) (sdName declaration) + | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate + ] + consumerModules = + [ hsModule (sdHaskell declaration) + | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate + ] + +mappedCodecHarnessExports :: Agg -> Text +mappedCodecHarnessExports aggregate = + T.concat + [ ", encode" <> sdName declaration <> "Mapped, decode" <> sdName declaration <> "Mapped" + | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate + ] + +fixtureSample :: QualifiedValueName -> Text +fixtureSample qualified = + "(snd (NonEmpty.head (fixtureCases " <> unQualifiedValueName qualified <> ")))" + +splitQualifiedHarness :: Text -> (Text, Text) +splitQualifiedHarness value = + let (prefix, name) = T.breakOnEnd "." value + in (T.dropEnd 1 prefix, name) + +unique :: (Eq value) => [value] -> [value] +unique = foldr (\value values -> if value `elem` values then values else value : values) [] + +hasMappedHarness :: Agg -> Bool +hasMappedHarness = not . null . mappedHarnessDeclarationsResolved + +mappedHarnessDeclarationsResolved :: Agg -> [ResolvedMappedDecl] +mappedHarnessDeclarationsResolved aggregate = case aTypeGraph aggregate of + Nothing -> [] + Just graph -> Map.elems (tgDeclarations graph) + +mappedProjectionSpecs :: Agg -> [StructuralProjection] +mappedProjectionSpecs aggregate = case aTypeGraph aggregate of + Nothing -> [] + Just graph -> map (resolveProjectionModules (aContext aggregate)) (projectionSpecs graph) + +structuralShapeModuleName :: Context -> Name -> Text +structuralShapeModuleName context name = case placement context of + GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".Structural.Shape." <> name + CollocatedLeaf -> root <> contextSegment <> ".Generated.Structural.Shape." <> name + where + root = if T.null (moduleRoot context) then "" else moduleRoot context <> "." + contextSegment = pascalFromKebab (contextName context) + +structuralProjectionModuleName :: Context -> Text +structuralProjectionModuleName context = case placement context of + GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".StructuralProjections" + CollocatedLeaf -> root <> contextSegment <> ".Generated.StructuralProjections" + where + root = if T.null (moduleRoot context) then "" else moduleRoot context <> "." + contextSegment = pascalFromKebab (contextName context) + +mappedHarnessDeclarations :: Agg -> [Text] +mappedHarnessDeclarations aggregate + | not (hasMappedHarness aggregate) = [] + | otherwise = + [ "" + , "mappedConformanceAssertions :: [(String, Bool)]" + , "mappedConformanceAssertions =" + , " concat" + , " [ " <> T.intercalate "\n , " assertionLists + , " ]" + , "" + , "validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool" + , "validFixtureLabels cases =" + , " all (not . T.null) labels && length labels == length (nub labels)" + , " where" + , " labels = map fst (NonEmpty.toList cases)" + ] + ++ concatMap (bindingAssertionDecl aggregate) structural + ++ concatMap (opaqueAssertionDecl aggregate) opaque + ++ concatMap (coverageDecl aggregate) structural + ++ concatMap (mappedEventAssertionDecl aggregate) mappedEventFields + ++ wirePolicyAssertionDecls aggregate structuralWire + ++ projectionAssertionDecls aggregate structural + ++ wirePolicyHelpers structuralWire + where + declarations = mappedHarnessDeclarationsResolved aggregate + structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations] + opaque = [declaration | ResolvedOpaque declaration <- declarations] + structuralWire = [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate] + mappedEventFields = + [ (event, fieldName, fieldType, declaration) + | event <- aEvents aggregate + , (fieldName, fieldType) <- rcFields event + , declaration <- maybeToListHarness (mappedDeclaration aggregate fieldType) + ] + assertionLists = + [lowerFirst (sdName declaration) <> "BindingAssertions" | (declaration, _) <- structural] + <> [lowerFirst (odName declaration) <> "OpaqueAssertions" | declaration <- opaque] + <> [ "[(\"fixture coverage: " + <> unCanonicalTypeId (sdCanonical declaration) + <> "\", coverage" + <> sdName declaration + <> ")]" + | (declaration, _) <- structural + ] + <> [ mappedEventAssertionName event fieldName <> "Assertions" + | (event, fieldName, _, _) <- mappedEventFields + ] + <> ["structuralWirePolicyAssertions" | not (null structuralWire)] + <> ["structuralProjectionAssertions" | not (null (mappedProjectionSpecs aggregate))] + +mappedDeclaration :: Agg -> Text -> Maybe ResolvedMappedDecl +mappedDeclaration aggregate name = do + graph <- aTypeGraph aggregate + Map.lookup (MappedKey name) (tgDeclarations graph) + +bindingAssertionDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] +bindingAssertionDecl _aggregate (declaration, _shape) = + [ "" + , valueName <> " :: [(String, Bool)]" + , valueName <> " =" + , " (\"fixture labels: " <> canonical <> "\", validFixtureLabels cases) :" + , " (\"canonical identity: " <> canonical <> "\", canonicalTypeName (Proxy @" <> consumerType <> ") == " <> tshow canonical <> ") :" + , " concat" + , " [ [ (\"binding domain round-trip: " <> canonical <> "/\" <> T.unpack label, bindingDomainRoundTrip " <> binding <> " value)" + , " , (\"binding shape round-trip: " <> canonical <> "/\" <> T.unpack label, bindingShapeRoundTrip " <> binding <> " (bindingToShape " <> binding <> " value))" + , " ]" + , " | (label, value) <- NonEmpty.toList cases" + , " ]" + , " where" + , " cases = fixtureCases " <> fixtures + ] + where + valueName = lowerFirst (sdName declaration) <> "BindingAssertions" + canonical = unCanonicalTypeId (sdCanonical declaration) + consumerType = hsModule (sdHaskell declaration) <> "." <> hsType (sdHaskell declaration) + binding = unQualifiedValueName (sdBinding declaration) + fixtures = unQualifiedValueName (sdFixtures declaration) + +opaqueAssertionDecl :: Agg -> OpaqueDecl -> [Text] +opaqueAssertionDecl _aggregate declaration = + [ "" + , valueName <> " :: [(String, Bool)]" + , valueName <> " =" + , " (\"opaque boundary fixtures: " <> label <> "\", validFixtureLabels cases) :" + , " [ (\"opaque codec round-trip: " <> label <> "/\" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)" + , " | (caseLabel, value) <- NonEmpty.toList cases" + , " ]" + , " where" + , " cases = fixtureCases " <> fixtures + ] + where + valueName = lowerFirst (odName declaration) <> "OpaqueAssertions" + label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration) + fixtures = unQualifiedValueName (odFixtures declaration) + +coverageDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] +coverageDecl aggregate (declaration, shape) = + [ "" + , "coverage" <> sdName declaration <> " :: Bool" + , "coverage" <> sdName declaration <> " = " <> coverageExpression aggregate declaration shape + ] + +coverageExpression :: Agg -> StructuralDecl -> ResolvedMappedShape -> Text +coverageExpression aggregate declaration shape = case obligations of + [] -> "True" + _ -> T.intercalate " && " obligations <> "\n where\n shapes = map (bindingToShape " <> binding <> " . snd) (NonEmpty.toList (fixtureCases " <> fixtures <> "))" + where + shapeModule = structuralShapeModuleName (aContext aggregate) (sdName declaration) + binding = unQualifiedValueName (sdBinding declaration) + fixtures = unQualifiedValueName (sdFixtures declaration) + obligations = case shape of + RRecord _ _ fields -> concatMap (recordFieldObligation shapeModule) fields + REnum entries -> + [ "any (\\case " <> shapeModule <> "." <> weCtor entry <> " -> True; _ -> False) shapes" + | entry <- entries + ] + RUnion _ arms -> concatMap (unionArmObligations shapeModule) arms + +recordFieldObligation :: Text -> ResolvedWireField -> [Text] +recordFieldObligation shapeModule field = case rwfType field of + ROptional _ -> + [ "any (isNothing . " <> selector <> ") shapes" + , "any (isJust . " <> selector <> ") shapes" + ] + _ -> [] + where + selector = shapeModule <> "." <> rwfHaskell field + +unionArmObligations :: Text -> ResolvedWireArm -> [Text] +unionArmObligations shapeModule arm = + ["any (\\case " <> patternText <> " -> True; _ -> False) shapes"] <> optionalPayload + where + constructor = shapeModule <> "." <> rwaCtor arm + patternText = constructor <> maybe "" (const "{}") (rwaPayload arm) + optionalPayload = case rwaPayload arm of + Just (ROptional _) -> + [ "any (\\case " <> constructor <> " Nothing -> True; _ -> False) shapes" + , "any (\\case " <> constructor <> " (Just _) -> True; _ -> False) shapes" + ] + _ -> [] + +mappedEventAssertionDecl :: Agg -> (ResolvedCtor, Text, Text, ResolvedMappedDecl) -> [Text] +mappedEventAssertionDecl aggregate (event, fieldName, _fieldType, declaration) = + [ "" + , valueName <> "Assertions :: [(String, Bool)]" + , valueName <> "Assertions =" + , " [ (\"mapped codec round-trip: " <> rcName event <> "/" <> fieldName <> "/\" <> T.unpack label, roundTrips " <> eventExpression <> ")" + , " | (label, mappedValue) <- NonEmpty.toList (fixtureCases " <> fixtures <> ")" + , " ]" + ] + where + valueName = mappedEventAssertionName event fieldName + fixtures = unQualifiedValueName (mappedFixtures declaration) + eventExpression = ctorExprWithOverride aggregate event fieldName "mappedValue" + +mappedEventAssertionName :: ResolvedCtor -> Text -> Text +mappedEventAssertionName event fieldName = lowerFirst (rcName event) <> pascal fieldName + +wirePolicyAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text] +wirePolicyAssertionDecls _aggregate [] = [] +wirePolicyAssertionDecls aggregate declarations = + [ "" + , "structuralWirePolicyAssertions :: [(String, Bool)]" + , "structuralWirePolicyAssertions =" + , " [ " <> T.intercalate "\n , " assertions + , " ]" + ] + where + assertions = concatMap (wirePolicyAssertions aggregate) declarations + +wirePolicyAssertions :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] +wirePolicyAssertions aggregate (declaration, shape) = case shape of + RRecord _ unknownFields fields -> + concatMap (recordMissingAssertions aggregate declaration) [field | field <- fields, rwfPresence field == POptional] + <> [unknownFieldAssertion declaration unknownFields] + REnum entries -> map (enumArmAssertion declaration) entries <> [enumUnknownAssertion declaration] + RUnion encoding arms -> + map (unionArmAssertion declaration encoding) arms + <> [unknownFieldAssertion declaration (ueUnknownFields encoding)] + +recordMissingAssertions :: Agg -> StructuralDecl -> ResolvedWireField -> [Text] +recordMissingAssertions aggregate declaration field = + [ "(\"wire policy missing default: " + <> canonical + <> "/" + <> rwfKey field + <> "\", case " + <> decoder + <> " (deleteObjectField " + <> tshow (rwfKey field) + <> " (" + <> encodedSample + <> ")) of Left _ -> False; Right decoded -> objectField " + <> tshow (rwfKey field) + <> " (" + <> encoder + <> " decoded) == Just (" + <> missingExpectedValue aggregate field + <> "))" + , "(\"wire policy explicit null: " + <> canonical + <> "/" + <> rwfKey field + <> "\", " + <> nullExpectation + <> " (" + <> decoder + <> " (insertObjectField " + <> tshow (rwfKey field) + <> " Aeson.Null (" + <> encodedSample + <> "))))" + ] + where + canonical = unCanonicalTypeId (sdCanonical declaration) + encoder = "encode" <> sdName declaration <> "Mapped" + decoder = "decode" <> sdName declaration <> "Mapped" + fixtures = unQualifiedValueName (sdFixtures declaration) + encodedSample = encoder <> " (snd (NonEmpty.head (fixtureCases " <> fixtures <> ")))" + nullExpectation = case rwfType field of + ROptional _ -> "isRight" + _ -> "isLeft" + +missingExpectedValue :: Agg -> ResolvedWireField -> Text +missingExpectedValue aggregate field = case rwfOnMissing field of + Just OmNull -> "Aeson.Null" + Just (OmText value) -> "Aeson.String " <> tshow value + Just (OmInt value) -> "Aeson.toJSON (" <> T.pack (show value) <> " :: Int)" + Just (OmBool value) -> if value then "Aeson.Bool True" else "Aeson.Bool False" + Just OmEmptyList -> "Aeson.toJSON ([] :: [Aeson.Value])" + Just OmEmptyMap -> "Aeson.Object mempty" + Just (OmCtor constructor) -> case (aTypeGraph aggregate, rwfType field) of + (Just graph, RRef key) -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural _ (REnum entries)) -> case find ((== constructor) . weCtor) entries of + Just entry -> "Aeson.String " <> tshow (weTag entry) + Nothing -> "error \"missing enum default constructor\"" + _ -> "error \"non-enum constructor default\"" + _ -> "error \"non-reference constructor default\"" + Nothing -> "error \"optional field lacks on-missing policy\"" + +unknownFieldAssertion :: StructuralDecl -> UnknownFields -> Text +unknownFieldAssertion declaration policy = + "(\"wire policy unknown fields: " + <> unCanonicalTypeId (sdCanonical declaration) + <> "\", all (\\(_, value) -> " + <> expectation + <> " (decode" + <> sdName declaration + <> "Mapped (insertObjectField \"__keiro_unknown\" (Aeson.Bool True) (encode" + <> sdName declaration + <> "Mapped value)))) (NonEmpty.toList (fixtureCases " + <> unQualifiedValueName (sdFixtures declaration) + <> ")))" + where + expectation = case policy of + RejectUnknown -> "isLeft" + IgnoreUnknown -> "isRight" + +enumArmAssertion :: StructuralDecl -> WireEnum -> Text +enumArmAssertion declaration entry = + "(\"wire enum arm: " + <> unCanonicalTypeId (sdCanonical declaration) + <> "/" + <> weTag entry + <> "\", any (\\(_, value) -> encode" + <> sdName declaration + <> "Mapped value == Aeson.String " + <> tshow (weTag entry) + <> " && decode" + <> sdName declaration + <> "Mapped (Aeson.String " + <> tshow (weTag entry) + <> ") == Right value) (NonEmpty.toList (fixtureCases " + <> unQualifiedValueName (sdFixtures declaration) + <> ")))" + +enumUnknownAssertion :: StructuralDecl -> Text +enumUnknownAssertion declaration = + "(\"wire enum unknown tag: " + <> unCanonicalTypeId (sdCanonical declaration) + <> "\", isLeft (decode" + <> sdName declaration + <> "Mapped (Aeson.String \"__keiro_unknown\")))" + +unionArmAssertion :: StructuralDecl -> UnionEncoding -> ResolvedWireArm -> Text +unionArmAssertion declaration encoding arm = + "(\"wire union arm: " + <> unCanonicalTypeId (sdCanonical declaration) + <> "/" + <> rwaTag arm + <> "\", any (\\(_, value) -> objectField " + <> tshow (ueTagField encoding) + <> " (encode" + <> sdName declaration + <> "Mapped value) == Just (Aeson.String " + <> tshow (rwaTag arm) + <> ") && decode" + <> sdName declaration + <> "Mapped (encode" + <> sdName declaration + <> "Mapped value) == Right value) (NonEmpty.toList (fixtureCases " + <> unQualifiedValueName (sdFixtures declaration) + <> ")))" + +wirePolicyHelpers :: [(StructuralDecl, ResolvedMappedShape)] -> [Text] +wirePolicyHelpers [] = [] +wirePolicyHelpers _ = + [ "" + , "deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value" + , "deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)" + , "deleteObjectField _ value = value" + , "" + , "insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value" + , "insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)" + , "insertObjectField _ _ value = value" + , "" + , "objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value" + , "objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue" + , "objectField _ _ = Nothing" + ] + +mappedFixtures :: ResolvedMappedDecl -> QualifiedValueName +mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration +mappedFixtures (ResolvedOpaque declaration) = odFixtures declaration + +ctorExprWithOverride :: Agg -> ResolvedCtor -> Text -> Text -> Text +ctorExprWithOverride aggregate constructor target replacement = + "(" <> rcName constructor <> " (" <> rcName constructor <> "Data" <> arguments <> "))" + where + arguments = + T.concat + [ " " <> if fieldName == target then replacement else sampleValue aggregate fieldName fieldType + | (fieldName, fieldType) <- rcFields constructor + ] + +projectionAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text] +projectionAssertionDecls aggregate structural + | null specs = [] + | otherwise = + [ "" + , "structuralProjectionAssertions :: [(String, Bool)]" + , "structuralProjectionAssertions =" + , " [ " <> T.intercalate "\n , " (map assertion specs) + , " ]" + ] + where + specs = mappedProjectionSpecs aggregate + assertion spec = + "(\"projection witness agreement: " + <> unCanonicalTypeId (spCanonical spec) + <> spPointer spec + <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections." + <> spWitness spec + <> " (\\referenceOwner -> " + <> projectionGetter "referenceOwner" spec + <> ") owner) (NonEmpty.toList (fixtureCases " + <> ownerFixtures spec + <> ")))" + ownerFixtures spec = case find (\(declaration, _) -> sdCanonical declaration == spCanonical spec) structural of + Just (declaration, _) -> unQualifiedValueName (sdFixtures declaration) + Nothing -> "error \"projection owner fixtures missing\"" + +projectionGetter :: Text -> StructuralProjection -> Text +projectionGetter owner spec = + foldl + (\value (shapeModule, selector) -> shapeModule <> "." <> selector <> " (" <> value <> ")") + ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " " <> owner) + (spSelectors spec) + +maybeToListHarness :: Maybe value -> [value] +maybeToListHarness = maybe [] pure diff --git a/src/Keiro/Dsl/Manifest.hs b/src/Keiro/Dsl/Manifest.hs --- a/src/Keiro/Dsl/Manifest.hs +++ b/src/Keiro/Dsl/Manifest.hs @@ -16,7 +16,8 @@ * intake/emit/publisher (full integration path) => effectful-core, hasql-transaction, keiro, kiroku-store (…-intake-full) - * workqueue => aeson, keiro-pgmq, text (…-queue, …-queue-runtime) + * workqueue => aeson, keiro-core, keiro-pgmq, text + (…-queue, …-queue-runtime) * dispatch => aeson, effectful-core, keiro-pgmq, text (…-dispatch-full) * workflow/operation => containers, effectful-core, keiro, text @@ -35,6 +36,7 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar +import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) import Keiro.Dsl.Scaffold (ScaffoldModule (..)) {- | Render a Cabal-pasteable manifest from the modules a scaffold run produced @@ -56,6 +58,20 @@ , "build-depends:" ] ++ map (" , " <>) (manifestDependencies spec) + ++ consumerBlocks + where + plan = consumerPlan spec + consumerBlocks + | null (consumerMappings plan) = [] + | otherwise = + [ "" + , "consumer-packages:" + ] + ++ map (" " <>) (consumerPackages plan) + ++ [ "" + , "consumer-modules:" + ] + ++ map (" " <>) (consumerModules plan) {- | The dotted module name recovered from a 'ScaffoldModule' path: drop the trailing @.hs@ and replace @/@ with @.@. @@ -68,7 +84,7 @@ -} manifestDependencies :: Spec -> [Text] manifestDependencies spec = - sort (nub ("base" : concatMap depsForNode (specNodes spec))) + sort (nub ("base" : consumerPackages (consumerPlan spec) <> concatMap depsForNode (specNodes spec))) -- | The dependencies a single node kind implies (see the module header table). depsForNode :: Node -> [Text] @@ -80,7 +96,7 @@ NIntake{} -> integration NEmit{} -> integration NPublisher{} -> integration - NWorkqueue{} -> ["aeson", "keiro-pgmq", "text"] + NWorkqueue{} -> ["aeson", "keiro-core", "keiro-pgmq", "text"] NPgmqDispatch{} -> ["aeson", "effectful-core", "keiro-pgmq", "text"] NReadModel{} -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"] NWorkflow{} -> ["containers", "effectful-core", "keiro", "text"] diff --git a/src/Keiro/Dsl/MappedConsumer.hs b/src/Keiro/Dsl/MappedConsumer.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/MappedConsumer.hs @@ -0,0 +1,162 @@ +{- | One checked projection of mapped declarations for every scaffold +integration surface. Keeping dependency requirements and persisted identities +together prevents the manifest, preflight report, and scaffold record from +silently disagreeing. +-} +module Keiro.Dsl.MappedConsumer ( + ConsumerPlan (..), + MappingIdentity (..), + consumerPlan, +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) +import Data.List (nub, sort) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar (HaskellSource (..), Spec) +import Keiro.Dsl.TypeGraph + +data ConsumerPlan = ConsumerPlan + { consumerPackages :: ![Text] + , consumerModules :: ![Text] + , consumerMappings :: ![MappingIdentity] + } + deriving stock (Eq, Show) + +data MappingIdentity + = StructuralMapping + { mappingSpecName :: !Text + , mappingCanonicalType :: !Text + , mappingPackage :: !Text + , mappingModule :: !Text + , mappingType :: !Text + , mappingBindingSymbol :: !Text + , mappingBindingVersion :: !Text + } + | OpaqueMapping + { mappingSpecName :: !Text + , mappingPackage :: !Text + , mappingModule :: !Text + , mappingType :: !Text + , mappingCodecIdentity :: !Text + , mappingCodecVersion :: !Text + } + deriving stock (Eq, Show) + +instance ToJSON MappingIdentity where + toJSON StructuralMapping{mappingSpecName, mappingCanonicalType, mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} = + object + [ "schema" .= (1 :: Int) + , "mode" .= ("structural" :: Text) + , "specName" .= mappingSpecName + , "canonicalType" .= mappingCanonicalType + , "package" .= mappingPackage + , "module" .= mappingModule + , "type" .= mappingType + , "bindingSymbol" .= mappingBindingSymbol + , "bindingVersion" .= mappingBindingVersion + ] + toJSON OpaqueMapping{mappingSpecName, mappingPackage, mappingModule, mappingType, mappingCodecIdentity, mappingCodecVersion} = + object + [ "schema" .= (1 :: Int) + , "mode" .= ("opaque" :: Text) + , "specName" .= mappingSpecName + , "package" .= mappingPackage + , "module" .= mappingModule + , "type" .= mappingType + , "codecIdentity" .= mappingCodecIdentity + , "codecVersion" .= mappingCodecVersion + ] + +instance FromJSON MappingIdentity where + parseJSON = withObject "keiro-dsl mapping identity" $ \value -> do + schema <- value .: "schema" + if schema /= (1 :: Int) + then fail "unsupported mapping identity schema" + else do + mode <- value .: "mode" + case (mode :: Text) of + "structural" -> + StructuralMapping + <$> value .: "specName" + <*> value .: "canonicalType" + <*> value .: "package" + <*> value .: "module" + <*> value .: "type" + <*> value .: "bindingSymbol" + <*> value .: "bindingVersion" + "opaque" -> + OpaqueMapping + <$> value .: "specName" + <*> value .: "package" + <*> value .: "module" + <*> value .: "type" + <*> value .: "codecIdentity" + <*> value .: "codecVersion" + _ -> fail "unknown mapping identity mode" + +consumerPlan :: Spec -> ConsumerPlan +consumerPlan spec = case resolveTypeGraph spec of + Left _ -> ConsumerPlan [] [] [] + Right graph -> + ConsumerPlan + { consumerPackages = uniqueSorted [hsPackage (mappedSource declaration) | declaration <- declarations] + , consumerModules = uniqueSorted (concatMap mappedModules declarations) + , consumerMappings = sortMappings (map mappingIdentity declarations) + } + where + declarations = Map.elems (tgDeclarations graph) + +mappedSource :: ResolvedMappedDecl -> HaskellSource +mappedSource (ResolvedStructural declaration _) = sdHaskell declaration +mappedSource (ResolvedOpaque declaration) = odHaskell declaration + +mappedModules :: ResolvedMappedDecl -> [Text] +mappedModules (ResolvedStructural declaration _) = + hsModule (sdHaskell declaration) + : qualifiedModule (sdBinding declaration) + : qualifiedModule (sdFixtures declaration) + : maybe [] (pure . qualifiedModule) (sdInitial declaration) +mappedModules (ResolvedOpaque declaration) = + hsModule (odHaskell declaration) + : qualifiedModule (odFixtures declaration) + : maybe [] (pure . qualifiedModule) (odInitial declaration) + +mappingIdentity :: ResolvedMappedDecl -> MappingIdentity +mappingIdentity (ResolvedStructural declaration _) = + StructuralMapping + { mappingSpecName = sdName declaration + , mappingCanonicalType = unCanonicalTypeId (sdCanonical declaration) + , mappingPackage = hsPackage (sdHaskell declaration) + , mappingModule = hsModule (sdHaskell declaration) + , mappingType = hsType (sdHaskell declaration) + , mappingBindingSymbol = unQualifiedValueName (sdBinding declaration) + , mappingBindingVersion = unBindingVersion (sdBindingVersion declaration) + } +mappingIdentity (ResolvedOpaque declaration) = + OpaqueMapping + { mappingSpecName = odName declaration + , mappingPackage = hsPackage (odHaskell declaration) + , mappingModule = hsModule (odHaskell declaration) + , mappingType = hsType (odHaskell declaration) + , mappingCodecIdentity = unCodecIdentity (odCodecIdentity declaration) + , mappingCodecVersion = unCodecVersion (odCodecVersion declaration) + } + +qualifiedModule :: QualifiedValueName -> Text +qualifiedModule qualified = T.dropEnd 1 (fst (T.breakOnEnd "." (unQualifiedValueName qualified))) + +sortMappings :: [MappingIdentity] -> [MappingIdentity] +sortMappings = sortOnName + where + sortOnName [] = [] + sortOnName mappings = + [ mapping + | name <- sort (map mappingSpecName mappings) + , mapping <- mappings + , mappingSpecName mapping == name + ] + +uniqueSorted :: [Text] -> [Text] +uniqueSorted = sort . nub diff --git a/src/Keiro/Dsl/MappedDiff.hs b/src/Keiro/Dsl/MappedDiff.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/MappedDiff.hs @@ -0,0 +1,539 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +{- | Recursive, wire-aware differences for consumer-owned mapped types. + +This module deliberately returns mapped findings rather than importing the +ordinary 'Change' type: 'Keiro.Dsl.Diff' owns compatibility vectors and turns +each complete mapped use path into the appropriate event, snapshot, or build +finding. Keeping that seam acyclic also makes the recursive comparison usable +by mutation coverage without rendering a report. +-} +module Keiro.Dsl.MappedDiff ( + MappedFinding (..), + diffMapped, + renderMappedSubject, +) where + +import Data.List (find, nubBy, sortOn) +import Data.Map.Strict qualified as Map +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (DiagnosticCode (..)) + +data MappedFinding = MappedFinding + { mfDeclaration :: !Name + , mfLeaf :: !Text + , mfCode :: !DiagnosticCode + , mfDetail :: !Text + , mfUsePaths :: ![UsePath] + , mfOldUnknownFields :: !(Maybe UnknownFields) + } + deriving stock (Eq, Show) + +{- | Compare valid old/new mapped graphs. A spec that cannot resolve has +already failed @check@; the ordinary differ therefore emits no speculative +mapped compatibility claim for it. +-} +diffMapped :: Spec -> Spec -> [MappedFinding] +diffMapped oldSpec newSpec = case (resolveTypeGraph oldSpec, resolveTypeGraph newSpec) of + (Right oldGraph, Right newGraph) -> + concatMap (uncurry (diffDeclaration oldGraph newGraph)) matched + ++ map (addedDeclaration newGraph) added + ++ map (removedDeclaration oldGraph) removed + where + oldDeclarations = tgDeclarations oldGraph + newDeclarations = tgDeclarations newGraph + matched = + [ (oldDeclaration, newDeclaration) + | (key, newDeclaration) <- Map.toList newDeclarations + , oldDeclaration <- maybeToList (Map.lookup key oldDeclarations) + ] + added = + [ (key, declaration) + | (key, declaration) <- Map.toList newDeclarations + , Map.notMember key oldDeclarations + ] + removed = + [ (key, declaration) + | (key, declaration) <- Map.toList oldDeclarations + , Map.notMember key newDeclarations + ] + _ -> [] + +renderMappedSubject :: UsePath -> Text -> Text +renderMappedSubject path leaf = + renderUsePath path <> if T.null leaf then "" else " " <> leaf + +data DeclView + = StructuralView !StructuralDecl !ShapeView + | OpaqueView !OpaqueDecl + +data ShapeView + = RecordView !Name !UnknownFields ![ResolvedWireField] + | EnumView ![WireEnum] + | UnionView !UnionEncoding ![ResolvedWireArm] + +data ExprView + = ExprText + | ExprInt + | ExprBool + | ExprNatural + | ExprTime + | ExprJson + | ExprOptional !ExprView + | ExprList !ExprView + | ExprMap !ExprView + | ExprRef !MappedKey + deriving stock (Eq, Show) + +declView :: ResolvedMappedDecl -> DeclView +declView = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \declaration shape -> StructuralView declaration (shapeView shape) + , onOpaqueDecl = OpaqueView + } + +shapeView :: ResolvedMappedShape -> ShapeView +shapeView = + foldMappedShape + MappedShapeAlgebra + { onRecord = RecordView + , onEnum = EnumView + , onUnion = UnionView + } + +exprView :: ResolvedTypeExpr -> ExprView +exprView = + foldTypeExpr + TypeExprAlgebra + { onText = ExprText + , onInt = ExprInt + , onBool = ExprBool + , onNatural = ExprNatural + , onTime = ExprTime + , onJson = ExprJson + , onOptional = ExprOptional + , onList = ExprList + , onMap = ExprMap + , onRef = ExprRef + } + +diffDeclaration :: TypeGraph -> TypeGraph -> ResolvedMappedDecl -> ResolvedMappedDecl -> [MappedFinding] +diffDeclaration oldGraph newGraph oldResolved newResolved = + case (declView oldResolved, declView newResolved) of + (StructuralView oldDeclaration oldShape, StructuralView newDeclaration newShape) -> + metadataDiff paths oldDeclaration newDeclaration + ++ diffShape paths name oldShape newShape + (OpaqueView oldDeclaration, OpaqueView newDeclaration) -> + opaqueMetadataDiff paths oldDeclaration newDeclaration + _ -> + [ finding + paths + name + "" + MappedModeCrossed + "mapped declaration crossed the structural/opaque boundary; no structural proof can establish codec parity" + ] + where + name = resolvedName newResolved + paths = pathsFor oldGraph newGraph name + +metadataDiff :: [UsePath] -> StructuralDecl -> StructuralDecl -> [MappedFinding] +metadataDiff paths oldDeclaration newDeclaration = + [ finding + paths + name + "haskell" + MappedHaskellSourceChanged + "consumer package, module, or type changed without changing declared wire identity; recompile every affected consumer" + | sdHaskell oldDeclaration /= sdHaskell newDeclaration + ] + ++ [ finding + paths + name + "binding" + MappedBindingChanged + "binding symbol or binding-version changed; diff cannot inspect binding behavior, so run the two-law, codec, and historical-fixture conformance suite" + | (sdBinding oldDeclaration, sdBindingVersion oldDeclaration) + /= (sdBinding newDeclaration, sdBindingVersion newDeclaration) + ] + ++ [ finding + paths + name + "fixtures" + MappedFixturesChanged + "fixture evidence symbol changed; runtime wire policy is unchanged, but the complete conformance suite must run" + | sdFixtures oldDeclaration /= sdFixtures newDeclaration + ] + ++ [ finding + paths + name + "initial" + MappedInitialChanged + "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not" + | sdInitial oldDeclaration /= sdInitial newDeclaration + ] + ++ [ finding + paths + name + "canonical-type" + MappedCanonicalTypeChanged + "canonical type identity changed; rebuild generated projections and invalidate mapped snapshots while declared event bytes remain unchanged" + | sdCanonical oldDeclaration /= sdCanonical newDeclaration + ] + where + name = sdName newDeclaration + +opaqueMetadataDiff :: [UsePath] -> OpaqueDecl -> OpaqueDecl -> [MappedFinding] +opaqueMetadataDiff paths oldDeclaration newDeclaration = + [ finding + paths + name + "haskell" + MappedHaskellSourceChanged + "consumer package, module, or type changed without changing the opaque codec claim; recompile every affected consumer" + | odHaskell oldDeclaration /= odHaskell newDeclaration + ] + ++ [ finding + paths + name + "codec" + MappedOpaqueCodecChanged + "opaque codec identity or version changed; Keiro cannot inspect the codec and historical payload compatibility is unproven" + | (odCodecIdentity oldDeclaration, odCodecVersion oldDeclaration) + /= (odCodecIdentity newDeclaration, odCodecVersion newDeclaration) + ] + ++ [ finding + paths + name + "fixtures" + MappedFixturesChanged + "fixture evidence symbol changed; runtime codec identity is unchanged, but the complete conformance suite must run" + | odFixtures oldDeclaration /= odFixtures newDeclaration + ] + ++ [ finding + paths + name + "initial" + MappedInitialChanged + "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not" + | odInitial oldDeclaration /= odInitial newDeclaration + ] + where + name = odName newDeclaration + +diffShape :: [UsePath] -> Name -> ShapeView -> ShapeView -> [MappedFinding] +diffShape paths declaration oldShape newShape = case (oldShape, newShape) of + (RecordView oldConstructor oldUnknown oldFields, RecordView newConstructor newUnknown newFields) -> + [ finding + paths + declaration + "constructor" + MappedRecordConstructorChanged + "record constructor changed without changing the JSON wire identity; recompile affected consumers" + | oldConstructor /= newConstructor + ] + ++ [ finding + paths + declaration + "unknown-fields" + MappedUnionEncodingChanged + "record unknown-fields policy changed; historical and mixed-version decoding posture is no longer the same" + | oldUnknown /= newUnknown + ] + ++ diffRecord paths declaration oldUnknown oldFields newFields + (EnumView oldEntries, EnumView newEntries) -> diffEnum paths declaration oldEntries newEntries + (UnionView oldEncoding oldArms, UnionView newEncoding newArms) -> + [ finding + paths + declaration + "encoding" + MappedUnionEncodingChanged + "tagged-object encoding changed; version and upcast every affected private event root" + | oldEncoding /= newEncoding + ] + ++ diffUnion paths declaration oldArms newArms + _ -> + [ finding + paths + declaration + "shape" + MappedUnionEncodingChanged + "structural shape kind changed; version and upcast every affected private event root" + ] + +diffRecord :: [UsePath] -> Name -> UnknownFields -> [ResolvedWireField] -> [ResolvedWireField] -> [MappedFinding] +diffRecord paths declaration oldUnknown oldFields newFields = + concatMap (uncurry (diffField paths declaration)) matched + ++ map addedFinding added + ++ map removedFinding removed + where + (matched, added, removed) = pairFields oldFields newFields + addedFinding field = + (findingWithUnknown paths declaration (fieldLeaf field) code detail (Just oldUnknown)) + where + hasDefault = isJustValue (rwfOnMissing field) + code + | hasDefault = MappedFieldAddedWithDefault + | otherwise = MappedFieldAddedNoDefault + oldPolicy = case oldUnknown of RejectUnknown -> "reject"; IgnoreUnknown -> "ignore" + detail + | hasDefault = + "field added with an explicit on-missing default; new readers preserve old meaning, while old readers use unknown-fields=" + <> oldPolicy + | otherwise = + "field added without an on-missing default; old payloads do not contain it, so version and upcast every affected private event root" + removedFinding field = + finding + paths + declaration + (fieldLeaf field) + MappedFieldRemoved + "field removed; replay-relevant removal remains breaking even when a tolerant decoder would ignore the historical key" + +pairFields :: [ResolvedWireField] -> [ResolvedWireField] -> ([(ResolvedWireField, ResolvedWireField)], [ResolvedWireField], [ResolvedWireField]) +pairFields oldFields newFields = (exact <> fallback, added, removed) + where + exact = + [ (oldField, newField) + | newField <- newFields + , oldField <- maybeToList (find ((== rwfHaskell newField) . rwfHaskell) oldFields) + ] + matchedOld = map (rwfHaskell . fst) exact + matchedNew = map (rwfHaskell . snd) exact + unmatchedOld = [field | field <- oldFields, rwfHaskell field `notElem` matchedOld] + unmatchedNew = [field | field <- newFields, rwfHaskell field `notElem` matchedNew] + fallback = + [ (oldField, newField) + | newField <- unmatchedNew + , oldField <- maybeToList (find ((== rwfKey newField) . rwfKey) unmatchedOld) + ] + fallbackOld = map (rwfHaskell . fst) fallback + fallbackNew = map (rwfHaskell . snd) fallback + removed = [field | field <- unmatchedOld, rwfHaskell field `notElem` fallbackOld] + added = [field | field <- unmatchedNew, rwfHaskell field `notElem` fallbackNew] + +diffField :: [UsePath] -> Name -> ResolvedWireField -> ResolvedWireField -> [MappedFinding] +diffField paths declaration oldField newField = + [ finding + paths + declaration + leaf + MappedWireKeyChanged + ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root") + | rwfKey oldField /= rwfKey newField + ] + ++ [ finding + paths + declaration + leaf + MappedPresenceChanged + "field presence changed between required and optional; historical decode policy changed" + | rwfPresence oldField /= rwfPresence newField + ] + ++ defaultChanges + ++ diffExpr paths declaration (leaf <> ".type") (rwfType oldField) (rwfType newField) + where + leaf = fieldLeaf newField + defaultChanges = case (rwfOnMissing oldField, rwfOnMissing newField) of + (Just _, Nothing) -> + [ finding + paths + declaration + leaf + MappedDefaultRemoved + "on-missing default was removed; old payloads may no longer decode with preserved meaning" + ] + (oldDefault, newDefault) + | oldDefault /= newDefault -> + [ finding + paths + declaration + leaf + MappedDefaultChanged + "on-missing default changed; the same historical bytes now construct a different consumer value" + ] + _ -> [] + +diffExpr :: [UsePath] -> Name -> Text -> ResolvedTypeExpr -> ResolvedTypeExpr -> [MappedFinding] +diffExpr paths declaration leaf oldExpression newExpression = + case (exprView oldExpression, exprView newExpression) of + (oldView, newView) + | oldView == newView -> [] + (ExprOptional oldValue, ExprOptional newValue) -> recurse ".optional" oldValue newValue + (ExprList oldValue, ExprList newValue) -> recurse "[]" oldValue newValue + (ExprMap oldValue, ExprMap newValue) -> recurse "{}" oldValue newValue + (ExprOptional _, _) -> nullability + (_, ExprOptional _) -> nullability + _ -> + [ finding + paths + declaration + leaf + MappedFieldTypeChanged + "wire type changed; version and upcast every affected private event root" + ] + where + recurse suffix oldView newView = diffExprViews paths declaration (leaf <> suffix) oldView newView + nullability = + [ finding + paths + declaration + leaf + MappedNullabilityChanged + "Optional nullability changed; historical null and non-null meanings are no longer stable" + ] + +diffExprViews :: [UsePath] -> Name -> Text -> ExprView -> ExprView -> [MappedFinding] +diffExprViews paths declaration leaf oldView newView = case (oldView, newView) of + _ | oldView == newView -> [] + (ExprOptional oldValue, ExprOptional newValue) -> diffExprViews paths declaration (leaf <> ".optional") oldValue newValue + (ExprList oldValue, ExprList newValue) -> diffExprViews paths declaration (leaf <> "[]") oldValue newValue + (ExprMap oldValue, ExprMap newValue) -> diffExprViews paths declaration (leaf <> "{}") oldValue newValue + (ExprOptional _, _) -> nullability + (_, ExprOptional _) -> nullability + _ -> [finding paths declaration leaf MappedFieldTypeChanged "wire type changed; version and upcast every affected private event root"] + where + nullability = [finding paths declaration leaf MappedNullabilityChanged "Optional nullability changed; historical null and non-null meanings are no longer stable"] + +diffEnum :: [UsePath] -> Name -> [WireEnum] -> [WireEnum] -> [MappedFinding] +diffEnum paths declaration oldEntries newEntries = + [ finding + paths + declaration + (enumLeaf newEntry) + MappedEnumSpellingChanged + ("enum wire spelling changed '" <> weTag oldEntry <> "' -> '" <> weTag newEntry <> "'") + | newEntry <- newEntries + , oldEntry <- maybeToList (find ((== weCtor newEntry) . weCtor) oldEntries) + , weTag oldEntry /= weTag newEntry + ] + ++ [ finding + paths + declaration + (enumLeaf entry) + MappedEnumValueAdded + "enum value added; existing history remains readable, but deploy readers before writers emit the new spelling; a future public surface exposing this closed enum would classify the addition as consumer-breaking" + | entry <- newEntries + , isNothing (find ((== weCtor entry) . weCtor) oldEntries) + ] + ++ [ finding + paths + declaration + (enumLeaf entry) + MappedEnumValueRemoved + "enum value removed; historical payloads carrying its wire spelling no longer decode" + | entry <- oldEntries + , isNothing (find ((== weCtor entry) . weCtor) newEntries) + ] + +diffUnion :: [UsePath] -> Name -> [ResolvedWireArm] -> [ResolvedWireArm] -> [MappedFinding] +diffUnion paths declaration oldArms newArms = + concatMap (uncurry pairedArm) matched + ++ map addedArm added + ++ map removedArm removed + where + (matched, added, removed) = pairArms oldArms newArms + pairedArm oldArm newArm = + [ finding + paths + declaration + (armLeaf newArm) + MappedArmTagChanged + ("union arm tag changed '" <> rwaTag oldArm <> "' -> '" <> rwaTag newArm <> "'") + | rwaTag oldArm /= rwaTag newArm + ] + ++ case (rwaPayload oldArm, rwaPayload newArm) of + (Nothing, Nothing) -> [] + (Just oldPayload, Just newPayload) -> diffExpr paths declaration (armLeaf newArm <> ".payload") oldPayload newPayload + _ -> [finding paths declaration (armLeaf newArm) MappedFieldTypeChanged "union arm payload presence changed; historical tagged objects no longer share one wire shape"] + addedArm arm = finding paths declaration (armLeaf arm) MappedArmAdded "union arm added; existing history remains readable, but older binaries cannot read the new arm once emitted, so deploy readers before writers; a future public surface exposing this closed union would classify the addition as consumer-breaking" + removedArm arm = finding paths declaration (armLeaf arm) MappedArmRemoved "union arm removed; historical tagged objects carrying that tag no longer decode" + +pairArms :: [ResolvedWireArm] -> [ResolvedWireArm] -> ([(ResolvedWireArm, ResolvedWireArm)], [ResolvedWireArm], [ResolvedWireArm]) +pairArms oldArms newArms = (exact <> fallback, added, removed) + where + exact = + [ (oldArm, newArm) + | newArm <- newArms + , oldArm <- maybeToList (find ((== rwaCtor newArm) . rwaCtor) oldArms) + ] + matchedOld = map (rwaCtor . fst) exact + matchedNew = map (rwaCtor . snd) exact + unmatchedOld = [arm | arm <- oldArms, rwaCtor arm `notElem` matchedOld] + unmatchedNew = [arm | arm <- newArms, rwaCtor arm `notElem` matchedNew] + fallback = + [ (oldArm, newArm) + | newArm <- unmatchedNew + , oldArm <- maybeToList (find ((== rwaTag newArm) . rwaTag) unmatchedOld) + ] + fallbackOld = map (rwaCtor . fst) fallback + fallbackNew = map (rwaCtor . snd) fallback + removed = [arm | arm <- unmatchedOld, rwaCtor arm `notElem` fallbackOld] + added = [arm | arm <- unmatchedNew, rwaCtor arm `notElem` fallbackNew] + +addedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding +addedDeclaration _ (key, _) = + finding + [] + (unMappedKey key) + "" + MappedDeclAdded + "new mapped declaration; use-site changes retain their own compatibility classification" + +removedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding +removedDeclaration graph (key, _) = + finding + (usePaths graph (unMappedKey key)) + (unMappedKey key) + "" + MappedDeclRemoved + "mapped declaration removed; persisted roots using its historical decoder require migration, while an unused source-only declaration requires consumer rebuild only" + +pathsFor :: TypeGraph -> TypeGraph -> Name -> [UsePath] +pathsFor oldGraph newGraph name = + nubBy sameRendered . sortOn renderUsePath $ usePaths oldGraph name <> usePaths newGraph name + where + sameRendered left right = renderUsePath left == renderUsePath right + +resolvedName :: ResolvedMappedDecl -> Name +resolvedName = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \declaration _ -> sdName declaration + , onOpaqueDecl = odName + } + +fieldLeaf :: ResolvedWireField -> Text +fieldLeaf field = ".field " <> rwfHaskell field <> "[\"" <> rwfKey field <> "\"]" + +armLeaf :: ResolvedWireArm -> Text +armLeaf arm = ".arm " <> rwaCtor arm <> "[\"" <> rwaTag arm <> "\"]" + +enumLeaf :: WireEnum -> Text +enumLeaf entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]" + +finding :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> MappedFinding +finding paths declaration leaf code detail = + findingWithUnknown paths declaration leaf code detail Nothing + +findingWithUnknown :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> Maybe UnknownFields -> MappedFinding +findingWithUnknown paths declaration leaf code detail unknownFields = + MappedFinding + { mfDeclaration = declaration + , mfLeaf = leaf + , mfCode = code + , mfDetail = detail + , mfUsePaths = paths + , mfOldUnknownFields = unknownFields + } + +isJustValue :: Maybe a -> Bool +isJustValue = not . isNothing + +maybeToList :: Maybe a -> [a] +maybeToList = maybe [] pure diff --git a/src/Keiro/Dsl/Parser.hs b/src/Keiro/Dsl/Parser.hs --- a/src/Keiro/Dsl/Parser.hs +++ b/src/Keiro/Dsl/Parser.hs @@ -14,6 +14,7 @@ import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isUpper) +import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Void (Void) @@ -118,6 +119,7 @@ , "id" , "enum" , "rule" + , "mapped" , "ex" , "aggregate" , "regs" @@ -136,6 +138,7 @@ , "status-map" , "true" , "false" + , "retiring" , "deprecated" , "upcast" , "from" @@ -232,6 +235,7 @@ = TIId IdDecl | TIEnum EnumDecl | TIRule RuleDecl + | TIMapped MappedDecl | TINode Node pSpec :: P Spec @@ -249,6 +253,7 @@ , specIds = [d | TIId d <- items] , specEnums = [d | TIEnum d <- items] , specRules = [d | TIRule d <- items] + , specMapped = [d | TIMapped d <- items] , specNodes = [n | TINode n <- items] } @@ -285,6 +290,7 @@ [ TIId <$> pIdDecl , TIEnum <$> pEnumDecl , TIRule <$> pRuleDecl + , TIMapped <$> pMappedDecl , TINode . NRouter <$> pRouter , TINode . NProcess <$> pProcess , TINode . NContract <$> pContract @@ -350,6 +356,243 @@ pure (c, e) -------------------------------------------------------------------------------- +-- Consumer-owned mapped types (EP-149) +-------------------------------------------------------------------------------- + +data MappedKind = MappedRecord | MappedEnum | MappedUnion + +data MappedClause + = MCHaskell HaskellSource + | MCBinding Text + | MCBindingVersion Text + | MCCanonical Text + | MCFixtures Text + | MCInitial Text + | MCCodec Text + | MCCodecVersion Text + | MCShape MappedShape + +pMappedDecl :: P MappedDecl +pMappedDecl = do + loc <- getLoc + keyword "mapped" + choice [pStructural loc, pOpaque loc] + where + pStructural loc = do + keyword "structural" + kind <- + choice + [ MappedRecord <$ keyword "record" + , MappedEnum <$ keyword "enum" + , MappedUnion <$ keyword "union" + ] + name <- ident + clauses <- braces (many (pStructuralClause kind)) + hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses + binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses + bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses + canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses + fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses + initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses + shape <- requiredClause "wire" (\case MCShape value -> Just value; _ -> Nothing) clauses + pure + MappedStructural + { msName = name + , msHaskell = hs + , msBinding = binding + , msBindingVersion = bindingVersion + , msCanonical = canonical + , msFixtures = fixtures + , msInitial = initial + , msShape = shape + , msLoc = loc + } + + pOpaque loc = do + keyword "opaque" + name <- ident + clauses <- braces (many pOpaqueClause) + hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses + codec <- oneClause "codec" (\case MCCodec value -> Just value; _ -> Nothing) clauses + version <- oneClause "version" (\case MCCodecVersion value -> Just value; _ -> Nothing) clauses + fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses + initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses + pure + MappedOpaque + { moName = name + , moHaskell = hs + , moCodecId = codec + , moCodecVersion = version + , moFixtures = fixtures + , moInitial = initial + , moLoc = loc + } + +pStructuralClause :: MappedKind -> P MappedClause +pStructuralClause kind = + choice + [ MCHaskell <$> pHaskellSource + , MCBindingVersion <$> pQuotedFact "binding-version" + , MCBinding <$> pQuotedFact "binding" + , MCCanonical <$> pQuotedFact "canonical-type" + , MCFixtures <$> pQuotedFact "fixtures" + , MCInitial <$> pQuotedFact "initial" + , MCShape <$> pMappedShape kind + ] + +pOpaqueClause :: P MappedClause +pOpaqueClause = + choice + [ MCHaskell <$> pHaskellSource + , MCCodec <$> pQuotedFact "codec" + , MCCodecVersion <$> pQuotedFact "version" + , MCFixtures <$> pQuotedFact "fixtures" + , MCInitial <$> pQuotedFact "initial" + ] + +pHaskellSource :: P HaskellSource +pHaskellSource = do + keyword "haskell" + keyword "package" + _ <- symbol "=" + packageName <- wireWord + keyword "module" + _ <- symbol "=" + moduleName <- pModulePrefix + keyword "type" + _ <- symbol "=" + typeName <- ident + pure HaskellSource{hsPackage = packageName, hsModule = moduleName, hsType = typeName} + +pQuotedFact :: Text -> P Text +pQuotedFact factName = keyword factName *> symbol "=" *> stringLit + +pMappedShape :: MappedKind -> P MappedShape +pMappedShape kind = do + keyword "wire" + case kind of + MappedRecord -> do + keyword "object" + keyword "constructor" + _ <- symbol "=" + constructor <- ident + unknownFields <- pUnknownFieldsFact + fields <- braces (many pWireField) + pure (ShapeRecord constructor unknownFields fields) + MappedEnum -> do + keyword "string" + ShapeEnum <$> braces (many pWireEnum) + MappedUnion -> do + keyword "tagged-object" + keyword "tag" + _ <- symbol "=" + tagField <- stringLit + keyword "contents" + _ <- symbol "=" + contentsField <- stringLit + unknownFields <- pUnknownFieldsFact + arms <- braces (many pWireArm) + pure (ShapeUnion (TaggedObject tagField contentsField unknownFields) arms) + +pUnknownFieldsFact :: P UnknownFields +pUnknownFieldsFact = do + keyword "unknown-fields" + _ <- symbol "=" + choice [RejectUnknown <$ keyword "reject", IgnoreUnknown <$ keyword "ignore"] + +pWireField :: P WireField +pWireField = do + loc <- getLoc + haskellName <- ident + keyword "as" + wireKey <- stringLit + _ <- symbol ":" + fieldType <- pMappedTypeExpr + presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"] + onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing) + pure + WireField + { wfHaskell = haskellName + , wfKey = wireKey + , wfType = fieldType + , wfPresence = presence + , wfOnMissing = onMissing + , wfLoc = loc + } + +pWireEnum :: P WireEnum +pWireEnum = do + loc <- getLoc + constructor <- ident + keyword "as" + wireTag <- stringLit + pure WireEnum{weCtor = constructor, weTag = wireTag, weLoc = loc} + +pWireArm :: P WireArm +pWireArm = do + loc <- getLoc + constructor <- ident + keyword "as" + wireTag <- stringLit + payload <- optional (symbol ":" *> pMappedTypeExpr) + pure WireArm{waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc} + +pMappedTypeExpr :: P TypeExpr +pMappedTypeExpr = + choice + [ TOptional <$> (keyword "Optional" *> pTypeArgument) + , TList <$> (keyword "List" *> pTypeArgument) + , TMap <$> (keyword "Map" *> pTypeArgument) + , TText <$ keyword "Text" + , TInt <$ keyword "Int" + , TBool <$ keyword "Bool" + , TNatural <$ keyword "Natural" + , TTime <$ (keyword "Time" <|> keyword "UTCTime") + , TJson <$ keyword "Json" + , TRef <$> ident + ] + where + pTypeArgument = parens pMappedTypeExpr <|> pTypeAtom + pTypeAtom = + choice + [ TText <$ keyword "Text" + , TInt <$ keyword "Int" + , TBool <$ keyword "Bool" + , TNatural <$ keyword "Natural" + , TTime <$ (keyword "Time" <|> keyword "UTCTime") + , TJson <$ keyword "Json" + , TRef <$> ident + ] + +pOnMissing :: P OnMissing +pOnMissing = + choice + [ OmNull <$ keyword "null" + , OmEmptyList <$ (symbol "[" *> symbol "]") + , OmEmptyMap <$ (symbol "{" *> symbol "}") + , OmBool True <$ keyword "true" + , OmBool False <$ keyword "false" + , OmText <$> stringLit + , OmInt <$> integerLiteral + , OmCtor <$> ident + ] + +integerLiteral :: P Integer +integerLiteral = lexeme (L.signed (pure ()) L.decimal) + +oneClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P (Maybe a) +oneClause clauseName select clauses = + case mapMaybe select clauses of + [] -> pure Nothing + [value] -> pure (Just value) + _ -> fail ("duplicate " <> clauseName <> " clause in mapped declaration") + +requiredClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P a +requiredClause clauseName select clauses = do + found <- oneClause clauseName select clauses + maybe (fail ("missing " <> clauseName <> " clause in mapped structural declaration")) pure found + +-------------------------------------------------------------------------------- -- Aggregate node -------------------------------------------------------------------------------- @@ -428,6 +671,10 @@ -- 'pTransition'. pStateDecl = try $ do loc <- getLoc + -- A @replay-only@ transition marker directly after the states line + -- must not be swallowed: 'ident' would take @replay@ (hyphens are + -- not identifier characters) and strand @-only@. + notFollowedBy (keyword "replay-only") n <- ident term <- option False (True <$ symbol "!") notFollowedBy (symbol "--") @@ -477,7 +724,14 @@ pEvent :: P Event pEvent = do loc <- getLoc - dep <- option False (True <$ keyword "deprecated") + (retiring, deprecated) <- + option + (False, False) + ( choice + [ (True, False) <$ keyword "retiring" + , (False, True) <$ keyword "deprecated" + ] + ) keyword "event" name <- ident ver <- option 1 pVersion @@ -493,7 +747,8 @@ , evBody = body , evVersion = ver , evUpcastFrom = up - , evDeprecated = dep + , evRetiring = retiring + , evDeprecated = deprecated , evLoc = loc } where @@ -1458,6 +1713,9 @@ pTransition = do startOffset <- getOffset loc <- getLoc + -- Plan 143: a @replay-only@ prefix marks the transition as serving + -- inversion only; it lowers to a keiki 'ReplayOnly' edge. + mode <- option TmLive (TmReplayOnly <$ keyword "replay-only") src <- ident _ <- symbol "--" cmd <- ident @@ -1482,6 +1740,7 @@ , tWrites = [(r, e) | CWrite r e <- clauses] , tEmits = [n | CEmit n <- clauses] , tGoto = gt + , tMode = mode , tLoc = loc } diff --git a/src/Keiro/Dsl/PrettyPrint.hs b/src/Keiro/Dsl/PrettyPrint.hs --- a/src/Keiro/Dsl/PrettyPrint.hs +++ b/src/Keiro/Dsl/PrettyPrint.hs @@ -8,6 +8,12 @@ -} module Keiro.Dsl.PrettyPrint ( renderSpec, + renderTransition, + renderExpr, + renderHandleSurface, + renderResolveSurface, + renderRouterDispatchSurface, + renderTimerPayloadSurface, ) where @@ -19,10 +25,24 @@ -- | Render a whole spec to text. renderSpec :: Spec -> Text -renderSpec = renderStrict . layoutPretty opts . docSpec - where - opts = LayoutOptions{layoutPageWidth = Unbounded} +renderSpec = renderDoc . docSpec +renderHandleSurface :: HandleNode -> Text +renderHandleSurface = renderDoc . docHandle + +renderResolveSurface :: ResolveDecl -> Text +renderResolveSurface = renderDoc . docResolve + +renderRouterDispatchSurface :: RouterDispatchNode -> Text +renderRouterDispatchSurface = renderDoc . docRouterDispatch + +renderTimerPayloadSurface :: TimerNode -> Text +renderTimerPayloadSurface timer = + renderDoc ("payload" <+> braced (map docFieldBinding (tmPayload timer))) + +renderDoc :: Doc ann -> Text +renderDoc = renderStrict . layoutPretty LayoutOptions{layoutPageWidth = Unbounded} + docSpec :: Spec -> Doc ann docSpec s = vsep $ @@ -36,6 +56,8 @@ ++ blankAfter (specEnums s) ++ map docRule (specRules s) ++ blankAfter (specRules s) + ++ map docMapped (specMapped s) + ++ blankAfter (specMapped s) ++ map docNode (specNodes s) where blankAfter xs = if null xs then [] else [mempty] @@ -62,6 +84,121 @@ where cas (c, e) = pretty c <+> "=>" <+> docExpr 0 e +docMapped :: MappedDecl -> Doc ann +docMapped MappedStructural{msName = name, msHaskell = haskell, msBinding = binding, msBindingVersion = bindingVersion, msCanonical = canonical, msFixtures = fixtures, msInitial = initial, msShape = shape} = + vsep $ + ["mapped structural" <+> docShapeKind shape <+> pretty name <+> "{"] + ++ maybe [] (pure . indent 2 . docHaskellSource) haskell + ++ maybe [] (pure . indent 2 . docQuotedFact "binding") binding + ++ maybe [] (pure . indent 2 . docQuotedFact "binding-version") bindingVersion + ++ maybe [] (pure . indent 2 . docQuotedFact "canonical-type") canonical + ++ maybe [] (pure . indent 2 . docQuotedFact "fixtures") fixtures + ++ maybe [] (pure . indent 2 . docQuotedFact "initial") initial + ++ [indent 2 (docMappedShape shape), "}"] +docMapped MappedOpaque{moName = name, moHaskell = haskell, moCodecId = codec, moCodecVersion = version, moFixtures = fixtures, moInitial = initial} = + vsep $ + ["mapped opaque" <+> pretty name <+> "{"] + ++ maybe [] (pure . indent 2 . docHaskellSource) haskell + ++ maybe [] (pure . indent 2 . docQuotedFact "codec") codec + ++ maybe [] (pure . indent 2 . docQuotedFact "version") version + ++ maybe [] (pure . indent 2 . docQuotedFact "fixtures") fixtures + ++ maybe [] (pure . indent 2 . docQuotedFact "initial") initial + ++ ["}"] + +docShapeKind :: MappedShape -> Doc ann +docShapeKind (ShapeRecord _ _ _) = "record" +docShapeKind (ShapeEnum _) = "enum" +docShapeKind (ShapeUnion _ _) = "union" + +docHaskellSource :: HaskellSource -> Doc ann +docHaskellSource source = + "haskell" + <+> ("package=" <> pretty (hsPackage source)) + <+> ("module=" <> pretty (hsModule source)) + <+> ("type=" <> pretty (hsType source)) + +docQuotedFact :: Doc ann -> Text -> Doc ann +docQuotedFact label value = label <+> "=" <+> dquoted value + +docMappedShape :: MappedShape -> Doc ann +docMappedShape (ShapeRecord constructor unknownFields fields) = + vsep $ + [ "wire object" + <+> ("constructor=" <> pretty constructor) + <+> ("unknown-fields=" <> docUnknownFields unknownFields) + <+> "{" + ] + ++ map (indent 2 . docWireField) fields + ++ ["}"] +docMappedShape (ShapeEnum entries) = + vsep $ ["wire string {"] ++ map (indent 2 . docWireEnum) entries ++ ["}"] +docMappedShape (ShapeUnion encoding arms) = + vsep $ + [ "wire tagged-object" + <+> ("tag=" <> dquoted (ueTagField encoding)) + <+> ("contents=" <> dquoted (ueContentsField encoding)) + <+> ("unknown-fields=" <> docUnknownFields (ueUnknownFields encoding)) + <+> "{" + ] + ++ map (indent 2 . docWireArm) arms + ++ ["}"] + +docUnknownFields :: UnknownFields -> Doc ann +docUnknownFields RejectUnknown = "reject" +docUnknownFields IgnoreUnknown = "ignore" + +docWireField :: WireField -> Doc ann +docWireField field = + pretty (wfHaskell field) + <+> "as" + <+> dquoted (wfKey field) + <+> ":" + <+> docTypeExpr (wfType field) + <+> docPresence (wfPresence field) + <> maybe mempty (\value -> " on-missing=" <> docOnMissing value) (wfOnMissing field) + +docPresence :: Presence -> Doc ann +docPresence PRequired = "required" +docPresence POptional = "optional" + +docOnMissing :: OnMissing -> Doc ann +docOnMissing OmNull = "null" +docOnMissing (OmText value) = dquoted value +docOnMissing (OmInt value) = pretty value +docOnMissing (OmBool True) = "true" +docOnMissing (OmBool False) = "false" +docOnMissing OmEmptyList = "[]" +docOnMissing OmEmptyMap = "{}" +docOnMissing (OmCtor constructor) = pretty constructor + +docWireEnum :: WireEnum -> Doc ann +docWireEnum entry = pretty (weCtor entry) <+> "as" <+> dquoted (weTag entry) + +docWireArm :: WireArm -> Doc ann +docWireArm arm = + pretty (waCtor arm) + <+> "as" + <+> dquoted (waTag arm) + <> maybe mempty (\payload -> " : " <> docTypeExpr payload) (waPayload arm) + +docTypeExpr :: TypeExpr -> Doc ann +docTypeExpr TText = "Text" +docTypeExpr TInt = "Int" +docTypeExpr TBool = "Bool" +docTypeExpr TNatural = "Natural" +docTypeExpr TTime = "Time" +docTypeExpr TJson = "Json" +docTypeExpr (TOptional value) = "Optional" <+> docTypeArgument value +docTypeExpr (TList value) = "List" <+> docTypeArgument value +docTypeExpr (TMap value) = "Map" <+> docTypeArgument value +docTypeExpr (TRef name) = pretty name + +docTypeArgument :: TypeExpr -> Doc ann +docTypeArgument value@TOptional{} = parens (docTypeExpr value) +docTypeArgument value@TList{} = parens (docTypeExpr value) +docTypeArgument value@TMap{} = parens (docTypeExpr value) +docTypeArgument value = docTypeExpr value + docNode :: Node -> Doc ann docNode (NAggregate a) = docAggregate a docNode (NProcess p) = docProcess p @@ -549,7 +686,11 @@ Nothing -> line1 Just (m, _) -> vsep [line1, indent 2 ("upcast from v" <> pretty m <+> "=" <+> "HOLE")] where - kw = if evDeprecated e then "deprecated event" else "event" + kw = case (evRetiring e, evDeprecated e) of + (False, False) -> "event" + (True, False) -> "retiring event" + (False, True) -> "deprecated event" + (True, True) -> "retiring deprecated event" nameVer = pretty (evName e) <> (if evVersion e > 1 then " v" <> pretty (evVersion e) else mempty) @@ -558,12 +699,32 @@ EventFields fs -> braced (map docField fs) line1 = kw <+> nameVer <+> bodyDoc +{- | Render one transition in concrete @.keiro@ syntax. Exported for @diff@'s +guard-tightening advisory, which prints a paste-ready replay-only twin +(plan 143). +-} +renderTransition :: Transition -> Text +renderTransition = + renderStrict + . layoutPretty LayoutOptions{layoutPageWidth = Unbounded} + . docTransition + +-- | Render one expression in canonical concrete syntax. +renderExpr :: Expr -> Text +renderExpr = + renderStrict + . layoutPretty LayoutOptions{layoutPageWidth = Unbounded} + . docExpr 0 + docTransition :: Transition -> Doc ann docTransition t = vsep $ - [pretty (tSource t) <+> "--" <+> pretty (tCommand t) <+> "-->"] + [modePrefix <> pretty (tSource t) <+> "--" <+> pretty (tCommand t) <+> "-->"] ++ map (indent 2) clauses where + modePrefix = case tMode t of + TmLive -> mempty + TmReplayOnly -> "replay-only " clauses = maybe [] (\g -> ["guard" <+> docExpr 0 g]) (tGuard t) ++ map (\(r, e) -> "write" <+> pretty r <+> ":=" <+> docExpr 0 e) (tWrites t) diff --git a/src/Keiro/Dsl/ReadModelShape.hs b/src/Keiro/Dsl/ReadModelShape.hs --- a/src/Keiro/Dsl/ReadModelShape.hs +++ b/src/Keiro/Dsl/ReadModelShape.hs @@ -5,6 +5,7 @@ module Keiro.Dsl.ReadModelShape ( canonicalShape, deriveShapeHash, + fnv1a64, registryNameFor, subscriptionNameFor, ) where @@ -33,9 +34,14 @@ -- | A fixed-width FNV-1a-64 digest over the canonical shape's UTF-8 bytes. deriveShapeHash :: ReadModelNode -> Text deriveShapeHash readModel = - "fnv1a:" <> T.justifyRight 16 '0' (T.pack (showHex digest "")) + "fnv1a:" <> fnv1a64 (canonicalShape readModel) + +-- | A fixed-width FNV-1a-64 digest over a 'Text' value's UTF-8 bytes. +fnv1a64 :: Text -> Text +fnv1a64 input = + T.justifyRight 16 '0' (T.pack (showHex digest "")) where - digest = foldl' step offsetBasis (concatMap utf8Bytes (T.unpack (canonicalShape readModel))) + digest = foldl' step offsetBasis (concatMap utf8Bytes (T.unpack input)) step hash byte = (hash `xor` byte) * fnvPrime -- | The runtime registry identity derived from context and notation name. diff --git a/src/Keiro/Dsl/ReplayImpact.hs b/src/Keiro/Dsl/ReplayImpact.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/ReplayImpact.hs @@ -0,0 +1,236 @@ +{- | Stored-data replay impact for a specification diff. + +The ordinary differ classifies compatibility across every persisted surface. +This module answers a narrower deployment question: can the candidate binary +interpret an already-stored aggregate log differently? + +The result is deliberately conservative. New aggregates, events, and +transitions are replay-neutral because no old log depends on them. A removed +or changed old transition affects the event types emitted by either side, and +a decode-surface change affects that event type directly. Snapshot-bearing +streams are included whenever the fold itself can change. +-} +module Keiro.Dsl.ReplayImpact ( + AggregateImpact (..), + ReplayImpact (..), + replayImpact, + renderReplayImpact, +) where + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.List (delete, find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface) +import Keiro.Dsl.Grammar +import Keiro.Dsl.PrettyPrint (renderTransition) +import Keiro.Dsl.TypeGraph (MappedKey (..), TypeGraph (..), resolveTypeGraph, wireFingerprint) + +-- | The smallest conservative audit input for one aggregate. +data AggregateImpact = AggregateImpact + { eventTypes :: !(Set Name) + , includeSnapshotStreams :: !Bool + } + deriving stock (Eq, Show) + +-- | A deploy either preserves replay or carries per-aggregate audit inputs. +data ReplayImpact + = ReplayNeutral + | ReplayAffected !(Map Name AggregateImpact) + deriving stock (Eq, Show) + +instance ToJSON AggregateImpact where + toJSON impact = + object + [ "eventTypes" .= Set.toAscList (eventTypes impact) + , "includeSnapshotStreams" .= includeSnapshotStreams impact + ] + +instance ToJSON ReplayImpact where + toJSON ReplayNeutral = object ["verdict" .= ("replay-neutral" :: Text)] + toJSON (ReplayAffected aggregates) = + object + [ "verdict" .= ("affected" :: Text) + , "aggregates" .= aggregates + ] + +-- | Compute replay impact for every aggregate that existed in the old spec. +replayImpact :: Spec -> Spec -> ReplayImpact +replayImpact oldSpec newSpec = + case Map.filter hasImpact impacts of + filtered + | Map.null filtered -> ReplayNeutral + | otherwise -> ReplayAffected filtered + where + oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec] + newAggregates = Map.fromList [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec] + impacts = + Map.fromList + [ (name, maybe (removedAggregateImpact oldAggregate) (matchedAggregateImpact oldSpec newSpec oldAggregate) (Map.lookup name newAggregates)) + | (name, oldAggregate) <- oldAggregates + ] + +hasImpact :: AggregateImpact -> Bool +hasImpact impact = + not (Set.null (eventTypes impact)) + || includeSnapshotStreams impact + +removedAggregateImpact :: Aggregate -> AggregateImpact +removedAggregateImpact aggregate = + AggregateImpact + { eventTypes = Set.fromList (evName <$> aggEvents aggregate) + , includeSnapshotStreams = True + } + +matchedAggregateImpact :: Spec -> Spec -> Aggregate -> Aggregate -> AggregateImpact +matchedAggregateImpact oldSpec newSpec oldAggregate newAggregate = + AggregateImpact + { eventTypes = + decodeAffected + <> transitionAffected + <> if nonTransitionFoldChanged then oldEventTypes else Set.empty + , includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged + } + where + oldEventTypes = Set.fromList (evName <$> aggEvents oldAggregate) + decodeAffected = decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate + mappedRegisterChanged = + mappedRegisterSurface oldSpec oldAggregate + /= mappedRegisterSurface newSpec newAggregate + (transitionAffected, transitionFoldChanged) = + changedTransitionEvents (aggTransitions oldAggregate) (aggTransitions newAggregate) + nonTransitionFoldChanged = + aggregateFoldSurface oldSpec oldAggregate + /= aggregateFoldSurface + newSpec + newAggregate + { aggTransitions = aggTransitions oldAggregate + } + +decodeSurfaceAffected :: Spec -> Spec -> Aggregate -> Aggregate -> Set Name +decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate = + removedOrChanged <> wireAffected + where + newEvents = Map.fromList [(evName event, event) | event <- aggEvents newAggregate] + removedOrChanged = + Set.fromList + [ evName oldEvent + | oldEvent <- aggEvents oldAggregate + , maybe True ((/= eventSurface oldSpec oldAggregate oldEvent) . eventSurface newSpec newAggregate) (Map.lookup (evName oldEvent) newEvents) + ] + wireAffected + | aggWire oldAggregate == aggWire newAggregate = Set.empty + | otherwise = Set.fromList (evName <$> aggEvents oldAggregate) + +eventDecodeSurface :: Event -> (EventBody, Int, Maybe (Int, Hole)) +eventDecodeSurface event = + (evBody event, evVersion event, evUpcastFrom event) + +eventSurface :: Spec -> Aggregate -> Event -> ((EventBody, Int, Maybe (Int, Hole)), [(Name, Text)]) +eventSurface spec aggregate event = + (eventDecodeSurface event, mappedFieldSurface spec aggregate event) + +mappedFieldSurface :: Spec -> Aggregate -> Event -> [(Name, Text)] +mappedFieldSurface spec aggregate event = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> + [ (fieldName field, wireFingerprint graph typeName) + | field <- eventFields aggregate event + , typeName <- maybeToList (fieldType field) + , Map.member (MappedKey typeName) (tgDeclarations graph) + ] + +mappedRegisterSurface :: Spec -> Aggregate -> [(Name, Name, Text)] +mappedRegisterSurface spec aggregate = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> + [ (regName register, regType register, wireFingerprint graph (regType register)) + | register <- aggRegs aggregate + , Map.member (MappedKey (regType register)) (tgDeclarations graph) + ] + +eventFields :: Aggregate -> Event -> [Field] +eventFields aggregate event = case evBody event of + EventFields fields -> fields + EventFromCommand commandName -> + concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName] + +maybeToList :: Maybe a -> [a] +maybeToList = maybe [] pure + +changedTransitionEvents :: [Transition] -> [Transition] -> (Set Name, Bool) +changedTransitionEvents oldTransitions newTransitions = + go oldTransitions newTransitions Set.empty False + where + go [] _ affected changed = (affected, changed) + go (oldTransition : remainingOld) remainingNew affected changed = + case find (sameSurface oldTransition) remainingNew of + Just exact -> + go remainingOld (delete exact remainingNew) affected changed + Nothing -> + case find (sameIdentity oldTransition) remainingNew of + Just candidate + | guardOnlyLoosening oldTransition candidate -> + go remainingOld (delete candidate remainingNew) affected changed + | otherwise -> + go + remainingOld + (delete candidate remainingNew) + (affected <> emittedBy oldTransition <> emittedBy candidate) + True + Nothing -> + go + remainingOld + remainingNew + (affected <> emittedBy oldTransition) + True + + sameSurface left right = renderTransition left == renderTransition right + sameIdentity left right = + tMode left == tMode right + && tSource left == tSource right + && tCommand left == tCommand right + emittedBy = Set.fromList . tEmits + +{- | A syntactically provable loosening preserves every old transition match. + +Unknown shapes return 'False', deliberately over-approximating impact. The +recognized fragment proves @old => new@ through equality, true/false, +conjunction elimination, and disjunction introduction. +-} +guardOnlyLoosening :: Transition -> Transition -> Bool +guardOnlyLoosening oldTransition newTransition = + oldTransition{tGuard = tGuard newTransition} == newTransition + && guardImplies (tGuard oldTransition) (tGuard newTransition) + +guardImplies :: Maybe Expr -> Maybe Expr -> Bool +guardImplies _ Nothing = True +guardImplies Nothing (Just _) = False +guardImplies (Just oldGuard) (Just newGuard) = implies oldGuard newGuard + where + implies old new + | old == new = True + implies (EAtom (ABool False)) _ = True + implies _ (EAtom (ABool True)) = True + implies (EAnd left right) new = implies left new || implies right new + implies old (EOr left right) = implies old left || implies old right + implies _ _ = False + +renderReplayImpact :: ReplayImpact -> Text +renderReplayImpact ReplayNeutral = + "replay-neutral: stored-data replay is unchanged by this diff" +renderReplayImpact (ReplayAffected aggregates) = + "replay-affected: run the candidate binary's targeted replay audit for " + <> Text.intercalate + "; " + [ aggregateName + <> " events=[" + <> Text.intercalate "," (Set.toAscList (eventTypes impact)) + <> "] snapshots=" + <> if includeSnapshotStreams impact then "yes" else "no" + | (aggregateName, impact) <- Map.toAscList aggregates + ] diff --git a/src/Keiro/Dsl/Scaffold.hs b/src/Keiro/Dsl/Scaffold.hs --- a/src/Keiro/Dsl/Scaffold.hs +++ b/src/Keiro/Dsl/Scaffold.hs @@ -25,2005 +25,3280 @@ defaultContext, genPrefixFor, holePrefixFor, - scaffoldAggregate, - scaffoldProcess, - scaffoldRouter, - scaffoldContract, - scaffoldIntake, - scaffoldPublisher, - scaffoldWorkqueue, - scaffoldReadModel, - scaffoldRefusals, - windowSeconds, - - -- * Firewall self-check (M3) - FirewallSurface (..), - firewallSurface, - firewallBreaches, - - -- * Internal resolution, shared with "Keiro.Dsl.Harness" - Agg (..), - ResolvedCtor (..), - resolveAgg, - FieldCat (..), - fieldCat, - vertexCtor, - initialVertex, - firstEnumCtor, - lowerFirst, - pascal, - pascalFromKebab, - generatedBanner, -) where - -import Data.Char (isAlpha, isAlphaNum, isUpper, toLower, toUpper) -import Data.List (find) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Keiro.Dsl.Grammar -import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor) -import Keiro.Dsl.Validate (sagaCategoryError) -import Text.Read (readMaybe) - -{- | One emitted module: its on-disk path (relative to the scaffold @--out@ -directory), its full text, and whether it is overwritten every run -('Generated') or written only when absent ('HoleStub'). --} -data ScaffoldModule = ScaffoldModule - { modulePath :: !FilePath - , moduleText :: !Text - , kind :: !ModuleKind - , origin :: !Text - } - deriving stock (Eq, Show) - -data ModuleKind - = -- | @-- \@generated@; overwritten on every scaffold. - Generated - | -- | Hand-owned; created only when absent, never overwritten. - HoleStub - deriving stock (Eq, Show) - -{- | The threading context: the spec's @context@ name, the chosen output -module-namespace root, and the placement style. Extended additively (never -re-shaped) by later verticals. --} -data Context = Context - { contextName :: !Text - , moduleRoot :: !Text - -- ^ @""@ means no namespace prefix (the historical default). - , placement :: !Placement - -- ^ 'GeneratedPrefix' is the historical default. - } - deriving stock (Eq, Show) - -{- | A context with today's default placement ('GeneratedPrefix', no root prefix) -for the given @context@ name. Callers that do not care about placement (the -@parse@ path, tests) build their context with this. --} -defaultContext :: Text -> Context -defaultContext name = Context{contextName = name, moduleRoot = "", placement = GeneratedPrefix} - -{- | The generated-layer namespace for a node, honouring the root prefix and the -placement style. The 'Text' argument is the already-pascalised node name (e.g. -@Reservation@, @HospitalSurge@). For 'GeneratedPrefix' this is -@\.Generated.\.\@ (identical to the historical layout); for -'CollocatedLeaf' it is @\.\.\.Generated@. --} -genPrefixFor :: Context -> Text -> Text -genPrefixFor ctx node = case placement ctx of - GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> "." <> node - CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> "." <> node <> ".Generated" - -{- | The hand-owned (hole) namespace for a node: @\.\.\@ — -the same for both placement styles (holes always sit beside the domain). --} -holePrefixFor :: Context -> Text -> Text -holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node - --- | The root namespace prefix, dot-terminated, or @""@ when no root is set. -rootPrefix :: Context -> Text -rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "." - --- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@. -ctxPascalOf :: Context -> Text -ctxPascalOf = pascalFromKebab . contextName - --------------------------------------------------------------------------------- --- Firewall self-check (M3) --------------------------------------------------------------------------------- - -{- | The canonical keiki surface forbidden in generated modules. Symbolic -operators are matched as maximal Haskell symbol tokens, identifiers as complete -tokens, qualifiers by their leading module alias, and imports structurally. --} -data FirewallSurface = FirewallSurface - { forbiddenSymbolic :: ![Text] - , forbiddenIdents :: ![Text] - , forbiddenQualifiers :: ![Text] - , forbiddenImports :: ![Text] - , restrictedImports :: ![(Text, [Text])] - } - deriving stock (Eq, Show) - -firewallSurface :: FirewallSurface -firewallSurface = - FirewallSurface - { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"] - , forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"] - , forbiddenQualifiers = ["B"] - , forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"] - , -- Generated aggregate modules use the first two names; generated - -- harnesses use the final three to validate and step filled holes. - restrictedImports = [("Keiki.Core", ["RegFile", "HsPred", "defaultValidationOptions", "step", "validateTransducer"])] - } - -{- | Scan generated modules for firewall breaches, returning every offending -@(module path, token, 1-based line number)@. Only modules whose 'kind' is -'Generated' are scanned. Strings and comments are skipped, symbol runs use -maximal munch, and keiki imports are checked independently of token spelling. --} -firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)] -firewallBreaches mods = - [ (modulePath m, breach, n) - | m <- mods - , kind m == Generated - , (n, line) <- zip [1 ..] (T.lines (moduleText m)) - , breach <- lineBreaches line - ] - -lineBreaches :: Text -> [Text] -lineBreaches line = case importModule line of - Just _ -> importBreaches line - Nothing -> tokenBreaches (codeTokens line) - where - tokenBreaches = mapMaybe breachFor - breachFor (IdentToken ident) - | ident `elem` forbiddenIdents firewallSurface = Just ident - breachFor (QualifiedToken qualifier) - | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*") - breachFor (SymbolToken symbol) - | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol - breachFor _ = Nothing - -data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text - -codeTokens :: Text -> [CodeToken] -codeTokens = go . T.unpack - where - go [] = [] - go ('-' : '-' : _) = [] - go ('"' : rest) = go (dropString rest) - go ('\'' : rest) = go (dropChar rest) - go (c : rest) - | isIdentStart c = - let (identTail, afterIdent) = span isIdentContinue rest - ident = T.pack (c : identTail) - in case afterIdent of - '.' : next : more - | isUpper c && isIdentStart next -> - let (_member, afterMember) = span isIdentContinue more - in QualifiedToken ident : go afterMember - _ -> IdentToken ident : go afterIdent - | isSymbolChar c = - let (symbolTail, afterSymbol) = span isSymbolChar rest - in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol - | otherwise = go rest - isIdentStart c = isAlpha c || c == '_' - isIdentContinue c = isAlphaNum c || c == '_' || c == '\'' - isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) - dropString [] = [] - dropString ('\\' : _escaped : rest) = dropString rest - dropString ('"' : rest) = rest - dropString (_ : rest) = dropString rest - dropChar [] = [] - dropChar ('\\' : _escaped : rest) = dropChar rest - dropChar ('\'' : rest) = rest - dropChar (_ : rest) = dropChar rest - -importBreaches :: Text -> [Text] -importBreaches line = case importModule line of - Nothing -> [] - Just imported - | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported] - | Just allowed <- lookup imported (restrictedImports firewallSurface) - , not (hasAllowedExplicitImportList allowed line) -> - ["import:" <> imported] - | otherwise -> [] - -importModule :: Text -> Maybe Text -importModule line = case T.words (T.strip line) of - "import" : rest -> find (T.isPrefixOf "Keiki.") rest - _ -> Nothing - -hasAllowedExplicitImportList :: [Text] -> Text -> Bool -hasAllowedExplicitImportList allowed line = - case (T.breakOn "(" line, T.breakOnEnd ")" line) of - ((_, open), (close, _)) - | not (T.null open) && not (T.null close) -> - let inside = T.takeWhile (/= ')') (T.drop 1 open) - names = filter (not . T.null) (T.split (not . isAlphaNum) inside) - in all (`elem` allowed) names - _ -> False - --------------------------------------------------------------------------------- --- Derived naming --------------------------------------------------------------------------------- - --- | Resolved, denormalized view of an aggregate used by every emitter. -data Agg = Agg - { aContext :: !Context - , aCtxPascal :: !Text - , aName :: !Text - , aLoc :: !Loc - , aVertexType :: !Text - , aIds :: ![IdDecl] - , aEnums :: ![EnumDecl] - , aRegs :: ![RegDecl] - , aStates :: ![StateDecl] - , aCommands :: ![ResolvedCtor] - , aEvents :: ![ResolvedCtor] - , aTransitions :: ![Transition] - , aWire :: !WireSpec - , aProjection :: !(Maybe ProjectionSpec) - , aSnapshot :: !(Maybe SnapshotSpec) - , aReadModels :: ![ReadModelNode] - , aGenPrefix :: !Text - -- ^ e.g. @Generated.HospitalCapacity.Reservation@ - , aHolePrefix :: !Text - -- ^ e.g. @HospitalCapacity.Reservation@ - } - --- | A command or event constructor with its fully-resolved field types. -data ResolvedCtor = ResolvedCtor - { rcName :: !Text - , rcFields :: ![(Text, Text)] - -- ^ (field name, resolved Haskell type) - , rcVersion :: !Int - -- ^ EP-2: schema version (1 for commands and unversioned events). - , rcUpcastFrom :: !(Maybe Int) - -- ^ EP-2: the source version this event migrates from (the upcaster step). - } - -defaultWire :: WireSpec -defaultWire = WireSpec{wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1} - -resolveAgg :: Context -> Spec -> Aggregate -> Agg -resolveAgg ctx spec agg = - Agg - { aContext = ctx - , aCtxPascal = ctxPascal - , aName = nm - , aLoc = aggLoc agg - , aVertexType = vertexType - , aIds = specIds spec - , aEnums = specEnums spec - , aRegs = aggRegs agg - , aStates = aggStates agg - , aCommands = map resolveCommand (aggCommands agg) - , aEvents = map resolveEvent (aggEvents agg) - , aTransitions = aggTransitions agg - , aWire = fromMaybe defaultWire (aggWire agg) - , aProjection = aggProjection agg - , aSnapshot = aggSnapshot agg - , aReadModels = [readModel | NReadModel readModel <- specNodes spec] - , aGenPrefix = genPrefixFor ctx nm - , aHolePrefix = holePrefixFor ctx nm - } - where - nm = aggName agg - ctxPascal = pascalFromKebab (contextName ctx) - vertexType = nm <> "Vertex" - commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg] - resolveCommand c = (mkCtor (cmdName c) (cmdFields c)){rcVersion = 1, rcUpcastFrom = Nothing} - resolveEvent e = - (mkCtor (evName e) (eventFields e)) - { rcVersion = evVersion e - , rcUpcastFrom = fst <$> evUpcastFrom e - } - where - eventFields ev = case evBody ev of - EventFields fs -> fs - EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes) - mkCtor cn fs = - ResolvedCtor - { rcName = cn - , rcFields = map (\f -> (fieldName f, resolveFieldType f)) fs - , rcVersion = 1 - , rcUpcastFrom = Nothing - } - regTypes = [(regName r, regType r) | r <- aggRegs agg] - idNames = map idName (specIds spec) - enumNames = map enumName (specEnums spec) - -- A bare field reuses a register's type if one shares its name; else it - -- Pascal-cases to a declared id/enum/vertex; else falls back to Text. - resolveFieldType f = case fieldType f of - Just ty -> ty - Nothing -> - let nme = fieldName f - pas = pascal nme - in case lookup nme regTypes of - Just ty -> ty - Nothing - | pas `elem` idNames -> pas - | pas `elem` enumNames -> pas - | pas == vertexType -> pas - | otherwise -> "Text" - --------------------------------------------------------------------------------- --- Entry point --------------------------------------------------------------------------------- - -{- | Emit all modules for one aggregate. The 'Spec' is needed for the shared -id\/enum declarations. --} -scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule] -scaffoldAggregate ctx spec agg = - [ genModule a "Domain" (emitDomain a) - , genModule a "Codec" (emitCodec a) - , genModule a "EventStream" (emitEventStream a) - , genModule a "Projection" (emitProjection a) - , holeModule a (emitHoles a) - ] - where - a = resolveAgg ctx spec agg - -genModule :: Agg -> Text -> Text -> ScaffoldModule -genModule a name body = - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs") - , moduleText = body - , kind = Generated - , origin = nodeOrigin "aggregate" (aName a) (aLoc a) - } - -holeModule :: Agg -> Text -> ScaffoldModule -holeModule a body = - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs") - , moduleText = body - , kind = HoleStub - , origin = nodeOrigin "aggregate" (aName a) (aLoc a) - } - --------------------------------------------------------------------------------- --- Integration contract (EP-4): a self-contained payload ADT + codec --------------------------------------------------------------------------------- - -{- | Emit the deterministic, symbol-free contract layer: a payload ADT -(per-event records), the topic constants, the @messageType@ discriminator, and a -strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it -compiles standalone — the cross-service schema both producer and consumer agree -on. No keiki symbolic operator (firewall holds). --} -scaffoldContract :: Context -> ContractNode -> [ScaffoldModule] -scaffoldContract ctx c = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs") - , moduleText = emitContractGen genPrefix c - , kind = Generated - , origin = nodeOrigin "contract" (ctrName c) (ctrLoc c) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (ctrName c)) - -emitContractGen :: Text -> ContractNode -> Text -emitContractGen genPrefix c = - nl $ - [ "{-# LANGUAGE DuplicateRecordFields #-}" - , "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" - , generatedBanner - , "module " <> genPrefix <> ".Contract" - , " ( " <> payloadTy <> " (..)" - , nl [" , " <> ceName e <> "Data (..)" | e <- ctrEvents c] - , " , messageTypeOf" - , " , encode" <> payloadTy - , " , parse" <> payloadTy - , " ) where" - , "" - , "import Data.Aeson (Value, object, withObject, (.:), (.=))" - , "import Data.Aeson.Types (Parser, parseEither)" - , "import Data.Text (Text)" - , "import qualified Data.Text as T" - , "" - , "-- topic constants" - ] - ++ [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow t | (alias, t) <- ctrTopics c] - ++ [ "" - , "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")" - ] - ++ [emitPayloadAdt payloadTy (ctrEvents c)] - ++ [ "" - , "messageTypeOf :: " <> payloadTy <> " -> Text" - , "messageTypeOf = \\case" - ] - ++ [" " <> ceName e <> " {} -> " <> tshow (ceName e) | e <- ctrEvents c] - ++ [ "" - , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value" - , "encode" <> payloadTy <> " = \\case" - ] - ++ concatMap encodeArm (ctrEvents c) - ++ [ "" - , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy - , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)" - , " where" - , " go o = do" - , " kind <- o .: " <> tshow (ctrDiscriminator c) <> " :: Parser Text" - , " case kind of" - ] - ++ concatMap decodeArm (ctrEvents c) - ++ [ " _ -> fail \"unknown message type\"" - , "" - , "mapLeftText :: Either String b -> Either Text b" - , "mapLeftText = either (Left . T.pack) Right" - ] - where - payloadTy = pascal (ctrName c) <> "Payload" - encodeArm e = - [ " " <> ceName e <> " payload ->" - , " object" - ] - ++ [lead i kv | (i, kv) <- zip [(0 :: Int) ..] ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : [tshow (cfName f) <> " .= payload." <> cfName f | f <- ceFields e])] - ++ [" ]"] - lead 0 kv = " [ " <> kv - lead _ kv = " , " <> kv - decodeArm e = - [ " " <> tshow (ceName e) <> " ->" - , " " <> ceName e <> " <$> (" <> ceName e <> "Data" <> fieldApps (ceFields e) <> ")" - ] - fieldApps [] = "" - fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (cfName f) | f <- fs] - -emitPayloadAdt :: Text -> [ContractEvent] -> Text -emitPayloadAdt tyName events = - sectionsOf [map dataRecord events, [sumDecl]] - where - hsType CText = "Text" - hsType CInt = "Int" - hsType (CTypeId _) = "Text" - dataRecord e = - "data " - <> ceName e - <> "Data = " - <> ceName e - <> "Data { " - <> T.intercalate ", " [cfName f <> " :: !" <> hsType (cfType f) | f <- ceFields e] - <> " }\n deriving stock (Eq, Show)" - arm e = ceName e <> " !" <> ceName e <> "Data" - sumDecl = case events of - [] -> "data " <> tyName <> " = " <> tyName <> "Empty\n deriving stock (Eq, Show)" - (e : es) -> - nl $ - ["data " <> tyName <> " = " <> arm e] - ++ [" | " <> arm e2 | e2 <- es] - ++ [" deriving stock (Eq, Show)"] - --------------------------------------------------------------------------------- --- Integration intake (EP-4): inbox disposition vs the live Keiro.Inbox runtime --------------------------------------------------------------------------------- - -{- | Emit the inbox node's deterministic disposition wiring compiled against the -LIVE @Keiro.Inbox.Types@: the dedupe policy (a real 'InboxDedupePolicy') and a -disposition function over the real @InboxResult@ (Processed\/Duplicate\/ -InProgress\/PreviouslyFailed). This pins the dangerous inversions -(duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the -runtime types. The handler-level decode\/dedupe\/store failures are noted but not -part of @InboxResult@. Firewall holds (no keiki symbolic operator). --} -scaffoldIntake :: Context -> IntakeNode -> [ScaffoldModule] -scaffoldIntake ctx i = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs") - , moduleText = emitIntakeGen genPrefix i - , kind = Generated - , origin = nodeOrigin "intake" (inkName i) (inkLoc i) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (inkName i)) - -emitIntakeGen :: Text -> IntakeNode -> Text -emitIntakeGen genPrefix i = - nl - [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" - , generatedBanner - , "module " <> genPrefix <> ".Inbox" - , " ( InboxAck (..)" - , " , inboxDedupePolicy" - , " , inboxPersistence" - , " , inboxDisposition" - , " ) where" - , "" - , "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))" - , "" - , "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy." - , "inboxDedupePolicy :: InboxDedupePolicy" - , "inboxDedupePolicy = " <> inkDedupePolicy i - , "" - , "{- | Success-path envelope retention passed to runInboxTransactionWith." - , "Failures always retain their full operator-facing dead-letter envelope." - , "Dedupe-only success rows decode with an empty payload." - , "-}" - , "inboxPersistence :: InboxPersistence" - , "inboxPersistence = " <> persistenceCtor (inkPersist i) - , "" - , "-- The service's ack decision for each inbox classification." - , "data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter" - , " deriving stock (Eq, Show)" - , "" - , "-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult." - , "-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous" - , "-- inversions the spec states explicitly." - , "inboxDisposition :: InboxResult a -> InboxAck" - , "inboxDisposition r = case r of" - , " InboxProcessed _ -> " <> ackFor "processed" - , " InboxDuplicate -> " <> ackFor "duplicate" - , " InboxInProgress -> " <> ackFor "inProgress" - , " InboxPreviouslyFailed _ -> " <> ackFor "previouslyFailed" - , "" - , "-- handler-level failures (not InboxResult): decodeFailed => " - <> ackText "decodeFailed" - <> ", dedupeFailed => " - <> ackText "dedupeFailed" - <> ", storeFailed => " - <> ackText "storeFailed" - ] - where - act o = lookup o [(drOutcome r, drAction r) | r <- inkDisposition i] - ackFor o = case act o of - Just IAckOk -> "InboxAckOk" - Just (IRetry _) -> "InboxRetry" - Just (IDeadLetter _) -> "InboxDeadLetter" - Nothing -> "InboxRetry" - ackText o = case act o of - Just IAckOk -> "ackOk" - Just (IRetry _) -> "retry" - Just (IDeadLetter _) -> "deadLetter" - Nothing -> "retry" - persistenceCtor InkPersistFull = "PersistFullEnvelope" - persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly" - --------------------------------------------------------------------------------- --- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime --------------------------------------------------------------------------------- - -{- | Emit the publisher's at-least-once policy compiled against the LIVE -@Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff -curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds. --} -scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule] -scaffoldPublisher ctx pb = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs") - , moduleText = emitPublisherGen genPrefix pb - , kind = Generated - , origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (pubName pb)) - -emitPublisherGen :: Text -> PublisherNode -> Text -emitPublisherGen genPrefix pb = - nl - [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" - , generatedBanner - , "module " <> genPrefix <> ".Publisher" - , " ( publisherOrdering" - , " , publisherBackoff" - , " , publisherMaxAttempts" - , " ) where" - , "" - , "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))" - , "" - , "publisherOrdering :: OrderingPolicy" - , "publisherOrdering = " <> pubOrdering pb - , "" - , "publisherBackoff :: BackoffSchedule" - , "publisherBackoff = " <> backoffExpr (pubBackoff pb) - , "" - , "publisherMaxAttempts :: Int" - , "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb) - ] - where - backoffExpr b = case boKind b of - "constant" -> "ConstantBackoff " <> windowText (boWindow b) - "exponential" -> - "ExponentialBackoff ExponentialBackoffOptions { initial = " - <> windowText (boWindow b) - <> ", maxDelay = " - <> maybe "0" windowText (boMax b) - <> ", multiplier = " - <> fromMaybe "0" (boMultiplier b) - <> " }" - _ -> "error \"keiro-dsl: unlowerable backoff kind\"" - --------------------------------------------------------------------------------- --- pgmq workqueue (EP-5): a self-contained Job payload record + codec --------------------------------------------------------------------------------- - -{- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the -field→wire-name JSON codec, and the captured physical\/dlq\/table name constants. -Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup -predicate are holes (not emitted). Firewall holds. --} -scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule] -scaffoldWorkqueue ctx w = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs") - , moduleText = emitWorkqueueGen genPrefix w - , kind = Generated - , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) - } - , ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs") - , moduleText = emitQueuePolicy genPrefix w - , kind = Generated - , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (wqName w)) - -emitWorkqueueGen :: Text -> WorkqueueNode -> Text -emitWorkqueueGen genPrefix w = - nl $ - [ "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" - , generatedBanner - , "module " <> genPrefix <> ".Queue" - , " ( " <> payloadTy <> " (..)" - , " , encode" <> payloadTy - , " , parse" <> payloadTy - , " , queuePhysical, queueDlq, queueTable" - , groupKeyExport - , " ) where" - , "" - , "import Data.Aeson (Value, object, withObject, (.:), (.=))" - , "import Data.Aeson.Types (parseEither)" - , "import Data.Text (Text)" - , "import qualified Data.Text as T" - , "" - , "queuePhysical, queueDlq, queueTable :: Text" - , "queuePhysical = " <> tshow (wqPhysical w) - , "queueDlq = " <> tshow (wqDlq w) - , "queueTable = " <> tshow (wqTable w) - , "" - ] - ++ groupKeyLines - ++ [ "data " <> payloadTy <> " = " <> payloadTy - , " { " <> T.intercalate "\n , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w] - , " }" - , " deriving stock (Eq, Show)" - , "" - , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value" - , "encode" <> payloadTy <> " p =" - , " object" - ] - ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)] - ++ [ " ]" - , "" - , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy - , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)" - , " where" - , " go o = " <> payloadTy <> fieldApps (wqPayload w) - , "" - , "mapLeftText :: Either String b -> Either Text b" - , "mapLeftText = either (Left . T.pack) Right" - ] - where - payloadTy = wqPayloadName w - groupKeyExport = case wqGroupKey w of - Nothing -> "" - Just groupKey - | gkVia groupKey == "raw" -> " , groupKeyField, groupKeyFor" - | otherwise -> " , groupKeyField" - groupKeyLines = case wqGroupKey w of - Nothing -> [] - Just groupKey -> common <> derivationLines groupKey - where - common = - [ "groupKeyField :: Text" - , "groupKeyField = " <> tshow (gkField groupKey) - , "" - ] - derivationLines key - | gkVia key == "raw" = - [ "groupKeyFor :: " <> payloadTy <> " -> Text" - , "groupKeyFor payload = payload." <> gkField key - , "" - ] - | otherwise = - [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned." - , "-- Captured fixture: " <> fromMaybe "" (gkFixture key) - , "" - ] - hsType "bool" = "Bool" - hsType "int" = "Int" - hsType _ = "Text" - lead 0 kv = " [ " <> kv - lead _ kv = " , " <> kv - fieldApps [] = "" - fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs] - -{- | Emit the pgmq retry policy + JobOutcome disposition compiled against the -LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins -the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient) -and decodeFailure ⇒ Dead (poison). --} -emitQueuePolicy :: Text -> WorkqueueNode -> Text -emitQueuePolicy genPrefix w = - nl $ - [ "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> genPrefix <> ".QueuePolicy" - , " ( retryPolicy, jobOutcomeFor" - , " , jobOrdering, jobTuningFor, queueProvision" - , " ) where" - , "" - , "import Data.Text (Text)" - , "import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)" - , "" - , "jobOrdering :: JobOrdering" - , "jobOrdering = " <> orderingCtor - , "" - , "-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering." - , "jobTuningFor :: JobTuning -> JobTuning" - , "jobTuningFor = withOrdering jobOrdering" - , "" - , "-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard." - , "queueProvision :: QueueProvision" - , "queueProvision = " <> provisionExpr - , "" - , "retryPolicy :: RetryPolicy" - , "retryPolicy =" - , " RetryPolicy" - , " { maxRetries = " <> tshow' (wqMaxRetries w) - , " , defaultRetryDelay = RetryDelay " <> windowText (wqDelay w) - , " , useDeadLetter = " <> (if wqDlqOn w then "True" else "False") - , " }" - , "" - , "-- The consumer JobOutcome disposition over the spec's named domain outcomes," - , "-- lowered to the live Keiro.PGMQ.Job.JobOutcome." - , "jobOutcomeFor :: Text -> JobOutcome" - , "jobOutcomeFor o = case o of" - ] - ++ [" " <> tshow (wqdOutcome r) <> " -> " <> outcome (wqdAction r) | r <- wqDisposition w] - ++ [" _ -> Retry (RetryDelay " <> windowText (wqDelay w) <> ")"] - where - orderingCtor = case wqOrdering w of - WqUnordered -> "Unordered" - WqFifoThroughput -> "FifoThroughput" - WqFifoRoundRobin -> "FifoRoundRobin" - provisionExpr = fifoWrap baseProvision - fifoWrap expression = case wqOrdering w of - WqUnordered -> expression - _ -> "withFifoIndexProvision (" <> expression <> ")" - baseProvision = case wqProvision w of - WqStandard -> "standardProvision" - WqUnlogged -> "unloggedProvision" - WqPartitioned interval retention -> - "partitionedProvision (PartitionSpec { partitionInterval = " - <> tshow interval - <> ", retentionInterval = " - <> tshow retention - <> " })" - outcome IAckOk = "Done" - outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")" - outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr) - --------------------------------------------------------------------------------- --- First-class read models (EP-107) --------------------------------------------------------------------------------- - -{- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the -qualified-table constant shared by the hand-owned query and the generated -runtime record; @ReadModel@ re-exports it as part of the public surface. --} -scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule] -scaffoldReadModel ctx readModel = - [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel) - , generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel) - , ScaffoldModule - { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles" - , moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel - , kind = HoleStub - , origin = readModelOrigin - } - ] - where - nodeSegment = pascal (rmName readModel) - stem = readModelStem readModel - readModelModule = genPrefixFor ctx nodeSegment - tableModule = readModelModule <> ".ReadModelTable" - readModelHolePrefix = holePrefixFor ctx nodeSegment - readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel) - generated leaf body = - ScaffoldModule - { modulePath = modulePathFor readModelModule leaf - , moduleText = body - , kind = Generated - , origin = readModelOrigin - } - -modulePathFor :: Text -> Text -> FilePath -modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs") - -readModelStem :: ReadModelNode -> Text -readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName - -emitReadModelTable :: Text -> Text -> ReadModelNode -> Text -emitReadModelTable tableModule stem readModel = - nl - [ "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> tableModule <> " (" <> qualifiedName <> ") where" - , "" - , "import Data.Text (Text)" - , "import Keiro.Connection (qualifyTable)" - , "" - , "-- The fully-qualified, double-quoted data-table reference." - , qualifiedName <> " :: Text" - , qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel) - ] - where - qualifiedName = stem <> "QualifiedTable" - -emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text -emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel = - nl $ - [ "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> readModelModule <> ".ReadModel" - , " ( " <> T.intercalate "\n , " exports - , " ) where" - , "" - , "import Data.Functor (void)" - , "import Effectful (Eff, (:>))" - , "import " <> tableModule <> " (" <> qualifiedName <> ")" - , "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")" - ] - ++ asyncImports - ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)" - , "import Keiro.ReadModel.Rebuild qualified as Rebuild" - , "import Kiroku.Store.Effect (Store)" - , "import Kiroku.Store.Types (" <> kirokuTypes <> ")" - , "" - , readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType - , readModelName <> " =" - , " ReadModel" - , " { name = " <> tshow registryName - , " , tableName = " <> tshow (rmTable readModel) - , " , schema = " <> tshow (rmSchema readModel) - , " , subscriptionName = " <> tshow subscriptionName - , " , version = " <> tshow' (rmVersion readModel) - , " , shapeHash = " <> tshow (rmShape readModel) - , " , defaultConsistency = " <> consistencyExpr (rmConsistency readModel) - , " , strongScope = " <> scopeExpr (rmScope readModel) - , " , query = " <> queryName - , " }" - , "" - , "-- Call once at projection startup before serving queries." - , registerName <> " :: (Store :> es) => Eff es ()" - , registerName <> " =" - , " void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")" - , "" - , startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata" - , startName <> " =" - , " Rebuild.startRebuild " <> readModelName <> " " <> projectionNames - , "" - , finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)" - , finishName <> " =" - , " Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames - , "" - , abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata" - , abandonName <> " = Rebuild.abandonRebuild " <> readModelName - ] - ++ asyncDefinition - where - registryName = registryNameFor (contextName ctx) readModel - subscriptionName = subscriptionNameFor (contextName ctx) readModel - asyncName = registryName <> "-async" - readModelName = stem <> "ReadModel" - qualifiedName = stem <> "QualifiedTable" - registerName = "register" <> pascal stem - startName = "start" <> pascal stem <> "Rebuild" - finishName = "finish" <> pascal stem <> "Rebuild" - abandonName = "abandon" <> pascal stem <> "Rebuild" - asyncValueName = stem <> "AsyncProjection" - queryInputType = pascal stem <> "QueryInput" - queryResultType = pascal stem <> "QueryResult" - queryName = stem <> "Query" - applyName = "apply" <> pascal stem - exports = - [ readModelName - , qualifiedName - , registerName - , startName - , finishName - , abandonName - ] - ++ [asyncValueName | rmFeed readModel == RmSubscription] - holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] - asyncImports = case rmFeed readModel of - RmInline -> [] - RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"] - kirokuTypes = case rmFeed readModel of - RmInline -> "GlobalPosition" - RmSubscription -> "GlobalPosition, RecordedEvent (..)" - projectionNames = case rmFeed readModel of - RmInline -> "[]" - RmSubscription -> "[" <> tshow asyncName <> "]" - asyncDefinition = case rmFeed readModel of - RmInline -> [] - RmSubscription -> - [ "" - , asyncValueName <> " :: AsyncProjection" - , asyncValueName <> " =" - , " AsyncProjection" - , " { name = " <> tshow asyncName - , " , readModelName = " <> tshow registryName - , " , subscriptionName = " <> tshow subscriptionName - , " , applyRecorded = " <> applyName - , " , idempotencyKey = \\recorded -> recorded.eventId" - , " }" - ] - consistencyExpr Strong = "Strong" - consistencyExpr Eventual = "Eventual" - scopeExpr Nothing = "EntireLog" - scopeExpr (Just RmEntireLog) = "EntireLog" - scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName - -emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text -emitReadModelHoles tableModule readModelHolePrefix stem readModel = - nl $ - [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it." - , "module " <> readModelHolePrefix <> ".ReadModelHoles" - , " ( " <> T.intercalate "\n , " exports - , " ) where" - , "" - , "import " <> tableModule <> " (" <> qualifiedName <> ")" - , "import Hasql.Transaction qualified as Tx" - ] - ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription] - ++ [ "" - , "-- HOLE: replace these aliases with the real query input and result types." - , "type " <> queryInputType <> " = ()" - , "type " <> queryResultType <> " = ()" - , "" - , "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path." - , "-- Declared columns:" - ] - ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) - ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType - , queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query") - ] - ++ applyStub - where - qualifiedName = stem <> "QualifiedTable" - queryInputType = pascal stem <> "QueryInput" - queryResultType = pascal stem <> "QueryResult" - queryName = stem <> "Query" - applyName = "apply" <> pascal stem - exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] - applyStub = case rmFeed readModel of - RmInline -> [] - RmSubscription -> - [ "" - , "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe." - , applyName <> " :: RecordedEvent -> Tx.Transaction ()" - , applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply") - ] - -qualifiedTableLiteral :: ReadModelNode -> Text -qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel) - -quoteSqlIdentifier :: Text -> Text -quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\"" - -readModelColumnDoc :: RmColumn -> Text -readModelColumnDoc columnDecl = - rmcName columnDecl - <> " " - <> rmcType columnDecl - <> if rmcRequired columnDecl then " NOT NULL" else "" - --------------------------------------------------------------------------------- --- Router + shared worker-policy lowering (EP-108) --------------------------------------------------------------------------------- - -scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule] -scaffoldRouter ctx router = - [ ScaffoldModule - { modulePath = modulePathFor genPrefix "Router" - , moduleText = emitRouterGen genPrefix router - , kind = Generated - , origin = routerOrigin - } - , ScaffoldModule - { modulePath = modulePathFor holePrefix "RouterHoles" - , moduleText = emitRouterHoles holePrefix router - , kind = HoleStub - , origin = routerOrigin - } - ] - where - genPrefix = genPrefixFor ctx (rtId router) - holePrefix = holePrefixFor ctx (rtId router) - routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router) - -emitRouterGen :: Text -> RouterNode -> Text -emitRouterGen genPrefix router = - nl $ - [ "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> genPrefix <> ".Router" - , " ( " <> stem <> "Name" - , " , " <> stem <> "WorkerOptions" - , " ) where" - , "" - , "import Data.Text (Text)" - ] - ++ workerPolicyImports (rtPoison router) - ++ [ "" - , "-- The STABLE router name. It participates in every target-keyed" - , "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches." - , stem <> "Name :: Text" - , stem <> "Name = " <> tshow (rtName router) - , "" - , "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId," - , "-- targetStreamName, occurrence). Target-keyed, not positional." - , "" - , "-- Node-level worker policy lowered from the spec. Pass this value to" - , "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions." - ] - ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router) - where - stem = lowerFirst (rtId router) - -emitRouterHoles :: Text -> RouterNode -> Text -emitRouterHoles holePrefix router = - nl - [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies." - , "-- keiro-dsl creates it once and never overwrites it." - , "module " <> holePrefix <> ".RouterHoles () where" - , "" - , "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]" - , "-- Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> "." - , "-- The spec's 'stable' keyword acknowledges that retry attempts accumulate" - , "-- the UNION of resolved target identities. Keep the recipient set stable" - , "-- for a source event whenever an exact recipient set matters." - , "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name," - , "-- key, resolve, targetEventStream, and targetProjections; run it with" - , "-- runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions." - , "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> "." - , "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate" - , "-- event id against the TARGET stream via confirmBenignDuplicate before" - , "-- returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise." - ] - where - renderNames names = "[" <> T.intercalate ", " names <> "]" - -resolveSourceText :: ResolveSource -> Text -resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)" -resolveSourceText ResolveHole = "typed resolver hole" - -workerPolicyImports :: PolicyChoice -> [Text] -workerPolicyImports poison = - [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))" - , "import Shibuya.Core.Ack (RetryDelay (..))" - ] - ++ if poison == PolHalt - then [] - else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"] - -workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text] -workerOptionsLines valueName rejected poison = - [ valueName <> signature - , valueName <> argument <> " =" - , " WorkerOptions" - , " { poisonPolicy = " <> poisonExpr - , " , rejectedCommandPolicy = " <> rejectedExpr rejected - , " , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning" - , " , metrics = Nothing -- runtime configuration; install at call site" - , " }" - ] - where - signature = case poison of - PolHalt -> " :: WorkerOptions es msg" - _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg" - argument = case poison of - PolHalt -> "" - _ -> " poisonCallback" - poisonExpr = case poison of - PolHalt -> "PoisonHalt" - PolDeadLetter -> "PoisonDeadLetter poisonCallback" - PolSkip -> "PoisonSkip poisonCallback" - rejectedExpr = \case - PolHalt -> "RejectedHalt" - PolDeadLetter -> "RejectedDeadLetter" - PolSkip -> "RejectedSkip" - --------------------------------------------------------------------------------- --- Process manager + durable timer (EP-3) --------------------------------------------------------------------------------- - -{- | Emit the symbol-free deterministic wiring for a process manager + its timer -into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the -behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the -fire command). The @Generated@ module contains no keiki symbolic operator (the -saga's transducer is the separate aggregate hole), so the firewall invariant -holds. The timer worker uses the spec's @max-attempts@ ceiling, never the -dangerous @defaultTimerWorkerOptions@ (@Nothing@) default. --} -scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule] -scaffoldProcess ctx p = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs") - , moduleText = emitProcessGen ctxPascal genPrefix holePrefix p - , kind = Generated - , origin = nodeOrigin "process" (procId p) (procLoc p) - } - , ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs") - , moduleText = emitProcessHoles genPrefix holePrefix p - , kind = HoleStub - , origin = nodeOrigin "process" (procId p) (procLoc p) - } - ] - where - ctxPascal = pascalFromKebab (contextName ctx) - genPrefix = genPrefixFor ctx (procId p) - holePrefix = holePrefixFor ctx (procId p) - -emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text -emitProcessGen _ctxPascal genPrefix _holePrefix p = - nl $ - [ "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> genPrefix <> ".Process" - , " ( " <> lo <> "ProcessName" - , " , " <> lo <> "Category" - , " , " <> lo <> "ProcessWorkerOptions" - , " , " <> lo <> "TimerRequest" - , " , " <> lo <> "FireOutcome" - , " ) where" - , "" - , "import Data.Aeson (Value, object, (.=))" - , "import Data.Text (Text)" - , "import qualified Data.Text as T" - , "import Data.Time (UTCTime)" - , "import Data.UUID (UUID)" - , "import qualified Data.UUID.V5 as UUID.V5" - , "import Keiro.Command (CommandError (..))" - , "import Keiro.Stream qualified as Stream" - , "import Keiro.Timer (TimerId (..), TimerRequest (..))" - ] - ++ workerPolicyImports (procPoison p) - ++ [ "" - , "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped)." - , lo <> "ProcessName :: Text" - , lo <> "ProcessName = " <> tshow (procName p) - , "" - , "-- The validated saga stream category (hole-kind 5: referenced, never retyped)." - , "-- Saga streams are '-' via Keiro.Stream.entityStream." - , "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal." - , lo <> "Category :: Stream.StreamCategory a" - , lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName - , "" - , "-- Node-level worker policy lowered from the spec. Pass this value to" - , "-- Keiro.ProcessManager.runProcessManagerWorkerWith." - ] - ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p) - ++ [ "" - , "-- The deterministic timer-request builder: id derived from the correlation" - , "-- key (hole-kind 1), processManagerName referenced, payload from the spec." - , "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)" - , lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest" - , lo <> "TimerRequest correlationId fireAtTime =" - , " TimerRequest" - , " { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))" - , " , processManagerName = " <> lo <> "ProcessName" - , " , correlationId = correlationId" - , " , fireAt = fireAtTime" - , " , payload = " <> payloadExpr (tmPayload timer) - , " }" - , "" - , "-- The timer-fire disposition table (hole-kind 2), derived from the spec." - , "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion." - , "-- A duplicate append reaches on-error unless it is confirmed against the" - , "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:" - , "-- StreamName -> EventId -> CommandError -> Eff es Bool" - , "-- Fold True into the duplicate result and surface False as the failure." - , lo <> "FireOutcome :: Either CommandError a -> Maybe ()" - , lo <> "FireOutcome result = case result of" - , " Right{} -> " <> outcomeToMaybe (onOk fd) - , " Left CommandRejected -> " <> outcomeToMaybe (onReject fd) - , " Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> " -- explicit definition-bug arm" - , " Left{} -> " <> outcomeToMaybe (onError fd) - , "" - , "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer) - , "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the" - , "-- defaultTimerWorkerOptions Nothing ceiling that retries forever)." - , "" - , "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1)." - , "namedUuid :: Text -> UUID" - , "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))" - ] - where - lo = lowerFirst (procId p) - categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p)) - timer = procTimer p - fd = fireDisposition (tmFire timer) - -{- | The timer payload, restricted to the spec's literal (@name=\"value\"@) -bindings so it compiles in the deterministic builder. Bare fields and -ref-valued bindings are input-driven (the agent-written hole), not emitted. --} -payloadExpr :: [FieldBinding] -> Text -payloadExpr fs = case [b | b <- fs, isLiteral b] of - [] -> "object []" - lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]" - where - isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes) - kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)" - stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\"" - -showOutcome :: FireOutcome -> Text -showOutcome OFired = "Fired" -showOutcome ORetry = "Retry" - -outcomeToMaybe :: FireOutcome -> Text -outcomeToMaybe OFired = "Just () -- Fired" -outcomeToMaybe ORetry = "Nothing -- Retry" - -emitProcessHoles :: Text -> Text -> ProcessNode -> Text -emitProcessHoles _genPrefix holePrefix p = - nl - [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies." - , "-- keiro-dsl creates it once and never overwrites it." - , "module " <> holePrefix <> ".ProcessHoles () where" - , "" - , "-- HOLE handle: build the ProcessManagerAction (the self-advance" - , "-- '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input." - , "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;" - , "-- build target streams with entityStream " <> lowerFirst (procTarget p) <> "Category. Never concatenate raw stream names." - , "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;" - , "-- surgeDeadline observedAt = addUTCTime surgeWindow observedAt (TIME INJECTED)." - , "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire," - , "-- keyed by correlationId; the fired-event-id is the deterministic uuidv5 of" - , "-- " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId." - , "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate" - , "-- event id against the TARGET stream via confirmBenignDuplicate before" - , "-- returning PMCommandDuplicate. Its effective signature is:" - , "-- StreamName -> EventId -> CommandError -> Eff es Bool" - , "-- Hand-rolled paths must call it with the target stream and attempted event id," - , "-- fold True into the duplicate result, and surface False as the original failure." - , "-- Never pattern-match DuplicateEvent as success: event ids are globally unique." - ] - --------------------------------------------------------------------------------- --- Domain module --------------------------------------------------------------------------------- - -emitDomain :: Agg -> Text -emitDomain a = - nl $ - [ "{-# LANGUAGE DataKinds #-}" - , "{-# LANGUAGE DuplicateRecordFields #-}" - ] - ++ ["{-# LANGUAGE DeriveAnyClass #-}" | hasSnapshot a] - ++ [ "{-# LANGUAGE OverloadedStrings #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE TypeApplications #-}" - , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" - , generatedBanner - , "module " <> aGenPrefix a <> ".Domain where" - , "" - ] - ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a] - ++ [ "import Data.Proxy (Proxy (..))" - , "import Data.Text (Text)" - , "import GHC.Generics (Generic)" - , "import Keiki.Core (RegFile (..))" - ] - ++ ["import Keiki.Shape (CanonicalTypeName)" | hasSnapshot a] - ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)" - , "" - , sectionsOf - [ map (emitId a) (aIds a) - , map (emitEnum a) (aEnums a) - , [emitVertex a] - , map (emitRecord) (aCommands a) - , [emitSum (aName a <> "Command") (aCommands a)] - , map (emitRecord) (aEvents a) - , [emitSum (aName a <> "Event") (aEvents a)] - , [emitRegsType a, emitInitialRegs a] - , - [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)" - , "" - , "$(deriveWireCtorsAll ''" <> aName a <> "Event)" - ] - ] - ] - -hasSnapshot :: Agg -> Bool -hasSnapshot = maybe False (const True) . aSnapshot - -emitId :: Agg -> IdDecl -> Text -emitId a d = - nl $ - [ "newtype " <> idName d <> " = " <> idName d <> " Text" - , " deriving stock (Generic, Eq, Ord, Show)" - ] - ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] - ++ ["instance CanonicalTypeName " <> idName d | hasSnapshot a] - ++ [ "" - , lowerFirst (idName d) <> "Text :: " <> idName d <> " -> Text" - , lowerFirst (idName d) <> "Text (" <> idName d <> " t) = t" - ] - -emitEnum :: Agg -> EnumDecl -> Text -emitEnum a d = - nl $ - [ "data " <> enumName d <> " = " <> T.intercalate " | " (map fst (enumCtors d)) - , " deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)" - ] - ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] - ++ ["instance CanonicalTypeName " <> enumName d | hasSnapshot a] - ++ [ "" - , lowerFirst (enumName d) <> "Text :: " <> enumName d <> " -> Text" - , lowerFirst (enumName d) <> "Text = \\case" - , nl [" " <> c <> " -> " <> tshow w | (c, w) <- enumCtors d] - ] - -emitVertex :: Agg -> Text -emitVertex a = - nl $ - [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a)) - , " deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)" - ] - ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] - ++ ["instance CanonicalTypeName " <> aVertexType a | hasSnapshot a] - -emitRecord :: ResolvedCtor -> Text -emitRecord rc = - nl $ - [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data" - ] - ++ recordFields (rcFields rc) - ++ [" deriving stock (Generic, Eq, Show)"] - -recordFields :: [(Text, Text)] -> [Text] -recordFields [] = - [" {"] - <> [" }"] -recordFields fs = - [ lead i <> n <> " :: !" <> ty - | (i, (n, ty)) <- zip [(0 :: Int) ..] fs - ] - ++ [" }"] - where - lead 0 = " { " - lead _ = " , " - -emitSum :: Text -> [ResolvedCtor] -> Text -emitSum tyName ctors = - nl $ - [firstLine] ++ restLines ++ [" deriving stock (Generic, Eq, Show)"] - where - arm rc = rc' rc - rc' rc = rcName rc <> " !" <> rcName rc <> "Data" - (firstLine, restLines) = case ctors of - [] -> ("data " <> tyName <> " = ()", []) - (c : cs) -> - ( "data " <> tyName <> " = " <> arm c - , [" | " <> arm c2 | c2 <- cs] - ) - -emitRegsType :: Agg -> Text -emitRegsType a = - nl $ - ["type " <> aName a <> "Regs ="] - ++ regListLines (aRegs a) - -regListLines :: [RegDecl] -> [Text] -regListLines [] = [" '[]"] -regListLines rs = - [ lead i <> "'(" <> tshow (regName r) <> ", " <> regType r <> ")" - | (i, r) <- zip [(0 :: Int) ..] rs - ] - ++ [" ]"] - where - lead 0 = " '[ " - lead _ = " , " - -emitInitialRegs :: Agg -> Text -emitInitialRegs a = - nl $ - [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs" - , "initial" <> aName a <> "Regs =" - ] - ++ chain (aRegs a) - where - chain [] = [" RNil"] - chain rs = - [ " RCons (Proxy @" <> tshow (regName r) <> ") " <> regInitialValue a r <> " $" - | r <- init rs - ] - ++ [" RCons (Proxy @" <> tshow (regName lastR) <> ") " <> regInitialValue a lastR <> " RNil"] - where - lastR = last rs - --- | The Haskell initial value for a register, by the category of its type. -regInitialValue :: Agg -> RegDecl -> Text -regInitialValue a r - | regType r `elem` idNames = "(" <> regType r <> " \"\")" - | regType r == aVertexType a = maybe "(error \"invalid vertex initial\")" (vertexCtor a) (bareInitial r) - | regType r == "Text" = maybe "(error \"Text initial must be quoted\")" tshow (textInitial r) - | otherwise = maybe "(error \"invalid register initial\")" id (bareInitial r) - where - idNames = map idName (aIds a) - bareInitial reg = case regInitial reg of - RegInitBare value -> Just value - RegInitText _ -> Nothing - textInitial reg = case regInitial reg of - RegInitText value -> Just value - RegInitBare _ -> Nothing - --------------------------------------------------------------------------------- --- Codec module --------------------------------------------------------------------------------- - -emitCodec :: Agg -> Text -emitCodec a = - nl - [ "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> aGenPrefix a <> ".Codec (" - , " " <> lowerFirst (aName a) <> "Codec," - , " parse" <> aName a <> "Event," - , " encode" <> aName a <> "Event," - , ") where" - , "" - , "import " <> aGenPrefix a <> ".Domain" - , "import Data.Aeson (Value, object, withObject, (.:), (.=))" - , "import Data.Aeson.Types (Parser, parseEither)" - , "import Data.List.NonEmpty (NonEmpty (..))" - , "import Data.Text (Text)" - , "import qualified Data.Text as T" - , "import Keiro.Codec (Codec (..), EventType (..))" - , upcasterImport a - , "" - , emitEnumParsers a - , "" - , emitCodecValue a - , "" - , emitEncode a - , "" - , emitDecode a - , "" - , "mapLeftText :: Either String b -> Either Text b" - , "mapLeftText = either (Left . T.pack) Right" - ] - -emitEnumParsers :: Agg -> Text -emitEnumParsers a = sectionsOf [[emitEnumParser e | e <- aEnums a]] - -emitEnumParser :: EnumDecl -> Text -emitEnumParser d = - nl $ - [ "parse" <> enumName d <> " :: Text -> Parser " <> enumName d - , "parse" <> enumName d <> " = \\case" - ] - ++ [" " <> tshow w <> " -> pure " <> c | (c, w) <- enumCtors d] - ++ [" _ -> fail " <> tshow ("unknown " <> enumName d)] - -emitCodecValue :: Agg -> Text -emitCodecValue a = - nl $ - [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event" - , lowerFirst (aName a) <> "Codec =" - , " Codec" - , " { eventTypes = " <> eventTypesExpr - , " , eventType = \\case" - ] - ++ [" " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a] - ++ [ " , schemaVersion = " <> tshow' (maxEventVersion a) - , " , encode = encode" <> aName a <> "Event" - , " , decode = parse" <> aName a <> "Event" - , " , upcasters = " <> upcastersExpr a - , " }" - ] - where - eventTypesExpr = case map rcName (aEvents a) of - [] -> "error \"no events\"" - (e : es) -> "EventType " <> tshow e <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) es) <> "]" - --- | The codec's @schemaVersion@: the maximum declared event version (EP-2). -maxEventVersion :: Agg -> Int -maxEventVersion a = maximum (1 : map rcVersion (aEvents a)) - -{- | One @(sourceVersion, upcasterName)@ entry per event that declares an -@upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its -body is a hole in the hand-owned Holes module. --} -upcasterEntries :: Agg -> [(Int, Text)] -upcasterEntries a = - [ (m, "upcast" <> rcName e <> "V" <> tshow' m) - | e <- aEvents a - , Just m <- [rcUpcastFrom e] - ] - -upcastersExpr :: Agg -> Text -upcastersExpr a = - "[" <> T.intercalate ", " ["(" <> tshow' m <> ", const " <> fn <> ")" | (m, fn) <- upcasterEntries a] <> "]" - -{- | When the codec references upcasters, it imports their (hole) definitions -from the hand-owned Holes module. --} -upcasterImport :: Agg -> Text -upcasterImport a = case upcasterEntries a of - [] -> "" - es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " (map snd es) <> ")" - -emitEncode :: Agg -> Text -emitEncode a = - nl $ - [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value" - , "encode" <> aName a <> "Event = \\case" - ] - ++ concatMap encodeArm (aEvents a) - where - encodeArm e = - [ " " <> rcName e <> " payload ->" - , " object" - ] - ++ [ lead i <> kv - | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e)) - ] - ++ [" ]"] - lead 0 = " [ " - lead _ = " , " - encodeField (n, ty) = - tshow n - <> " .= " - <> case fieldCat a ty of - IdCat -> lowerFirst ty <> "Text payload." <> n - EnumCat -> lowerFirst ty <> "Text payload." <> n - _ -> "payload." <> n - -emitDecode :: Agg -> Text -emitDecode a = - nl $ - [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event" - , "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)" - , " where" - , " go o = do" - , " case tag of" - ] - ++ concatMap decodeArm (aEvents a) - ++ [" _ -> fail \"unknown event type\""] - where - decodeArm e = - [ " " <> tshow (rcName e) <> " ->" - , " " <> rcName e <> " <$> (" <> rcName e <> "Data" <> fieldApps (rcFields e) <> ")" - ] - fieldApps [] = "" - fieldApps fs = " <$> " <> T.intercalate " <*> " (map decodeField fs) - -- The first field uses <$> (handled above), the rest <*>. We instead build - -- a uniform list and join; for an empty record there are no fields. - decodeField (n, ty) = case fieldCat a ty of - IdCat -> "(" <> ty <> " <$> o .: " <> tshow n <> ")" - EnumCat -> "(o .: " <> tshow n <> " >>= parse" <> ty <> ")" - _ -> "o .: " <> tshow n - --------------------------------------------------------------------------------- --- EventStream module --------------------------------------------------------------------------------- - -emitEventStream :: Agg -> Text -emitEventStream a = - nl $ - [ generatedBanner - , "module " <> aGenPrefix a <> ".EventStream" - , " ( " <> lowerFirst (aName a) <> "Category" - , " , " <> lowerFirst (aName a) <> "EventStream" - , " , " <> lowerFirst (aName a) <> "EventStreamDef" - , " , " <> aName a <> "EventStream" - , " , " <> aName a <> "EventStreamDef" - ] - ++ [" , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a] - ++ [ " ) where" - , "" - , "import " <> aGenPrefix a <> ".Domain" - , "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)" - , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst (aName a) <> "Transducer)" - , "import Keiki.Core (HsPred)" - , "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))" - , "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)" - ] - ++ ["import Data.Text (Text)" | hasSnapshot a] - ++ ["import Keiro.Snapshot.Codec (defaultStateCodec)" | hasSnapshot a] - ++ [ "import Keiro.Stream qualified as Stream" - , "" - , "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped)." - , "-- Entity streams are '-' via Keiro.Stream.entityStream." - , "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof." - , lowerFirst (aName a) <> "Category :: Stream.StreamCategory a" - , lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName - , "" - , "type " <> aName a <> "EventStreamDef =" - , " EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event" - , "" - , "type " <> aName a <> "EventStream =" - , " ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event" - , "" - , lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef" - , lowerFirst (aName a) <> "EventStreamDef =" - , " EventStream" - , " { transducer = " <> lowerFirst (aName a) <> "Transducer" - , " , initialState = " <> initialVertex a - , " , initialRegisters = initial" <> aName a <> "Regs" - , " , eventCodec = " <> lowerFirst (aName a) <> "Codec" - , " , resolveStreamName = Stream.streamName" - , " , snapshotPolicy = " <> snapshotPolicyExpr a - , " , stateCodec = " <> stateCodecExpr a - , " }" - , "" - ] - ++ snapshotFixtureLines a - ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream" - , lowerFirst (aName a) <> "EventStream =" - , " mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef" - ] - where - categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a)) - -snapshotPolicyExpr :: Agg -> Text -snapshotPolicyExpr aggregate = case aSnapshot aggregate of - Nothing -> "Never" - Just snapshot -> case snapPolicy snapshot of - SnapEvery interval -> "Every " <> tshow' interval - SnapOnTerminal -> "OnTerminal" - -stateCodecExpr :: Agg -> Text -stateCodecExpr aggregate = case aSnapshot aggregate of - Nothing -> "Nothing" - Just snapshot -> "Just (defaultStateCodec " <> tshow' (snapCodecVersion snapshot) <> ")" - -snapshotFixtureLines :: Agg -> [Text] -snapshotFixtureLines aggregate = case aSnapshot aggregate of - Nothing -> [] - Just snapshot -> - [ lowerFirst (aName aggregate) <> "SnapshotFixture :: (Int, Text)" - , lowerFirst (aName aggregate) <> "SnapshotFixture = (" <> tshow' (snapCodecVersion snapshot) <> ", " <> tshow (snapShapeHash snapshot) <> ")" - , "" - ] - --------------------------------------------------------------------------------- --- Projection module --------------------------------------------------------------------------------- - -emitProjection :: Agg -> Text -emitProjection a = case aProjection a of - Nothing -> nl [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"] - Just p -> - nl - [ "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , generatedBanner - , "module " <> aGenPrefix a <> ".Projection" - , " ( " <> lowerFirst (projTable p) <> "Projection" - , " , " <> lowerFirst (projTable p) <> "StatusFor" - , " ) where" - , "" - , "import " <> aGenPrefix a <> ".Domain" - , "import " <> aHolePrefix a <> ".Holes (apply" <> pascal (projTable p) <> ")" - , "import Data.Text (Text)" - , "import Keiro.Projection (InlineProjection (..))" - , "" - , "-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived" - , "-- from the spec's status-map. The read-model SQL that consumes it lives in" - , "-- the hand-owned Holes module (a DB-coupled hole, delegated to codd)." - , projectionTableComment a p - , lowerFirst (projTable p) <> "StatusFor :: " <> aName a <> "Event -> Maybe Text" - , lowerFirst (projTable p) <> "StatusFor = \\case" - , nl (statusArms a p) - , "" - , lowerFirst (projTable p) <> "Projection :: InlineProjection " <> aName a <> "Event" - , lowerFirst (projTable p) <> "Projection =" - , " InlineProjection" - , " { name = " <> tshow (contextNameToProjName a p) - , " , apply = apply" <> pascal (projTable p) - , " }" - ] - -statusArms :: Agg -> ProjectionSpec -> [Text] -statusArms a p = - [ " " <> rcName e <> " {} -> " <> statusFor e - | e <- aEvents a - ] - ++ [" _ -> Nothing" | hasWildcard] - where - pairs = maybe [] mapPairs (projStatusMap p) - statusFor e = case lookup (rcName e) pairs of - Just value -> "Just " <> tshow value - Nothing -> "Nothing" - -- A wildcard is only needed if some event is uncovered; otherwise every arm - -- is explicit and a wildcard would be redundant (and -Wall would warn). - hasWildcard = False - -contextNameToProjName :: Agg -> ProjectionSpec -> Text -contextNameToProjName a p = contextKebab a <> "-" <> projTable p <> "-inline" - -contextKebab :: Agg -> Text -contextKebab = kebabFromPascal . aCtxPascal - -projectionReadModel :: Agg -> Maybe ReadModelNode -projectionReadModel aggregate = do - projection <- aProjection aggregate - find ((== projTable projection) . rmName) (aReadModels aggregate) - -projectionTableComment :: Agg -> ProjectionSpec -> Text -projectionTableComment aggregate projection = case projectionReadModel aggregate of - Nothing -> - "-- WARNING: no readmodel node declares '" - <> projTable projection - <> "'; unqualified SQL depends on search_path." - Just readModel -> - "-- Qualified table " - <> qualifiedTableLiteral readModel - <> "; use " - <> genPrefixFor (aContext aggregate) (pascal (rmName readModel)) - <> ".ReadModelTable." - <> readModelStem readModel - <> "QualifiedTable." - --------------------------------------------------------------------------------- --- Holes module (create-if-absent) --------------------------------------------------------------------------------- - -emitHoles :: Agg -> Text -emitHoles a = - nl - [ "{-# LANGUAGE BlockArguments #-}" - , "{-# LANGUAGE DataKinds #-}" - , "{-# LANGUAGE OverloadedRecordDot #-}" - , "{-# LANGUAGE QualifiedDo #-}" - , "{-# LANGUAGE TypeApplications #-}" - , "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never" - , "-- overwrites it. Fill the transducer body (and any other holes) against the" - , "-- generated signatures, then run the harness to confirm behaviour." - , "module " <> aHolePrefix a <> ".Holes" - , " ( " <> lowerFirst (aName a) <> "Transducer" - , holeProjectionExport a - , holeUpcasterExports a - , " ) where" - , "" - , "import " <> aGenPrefix a <> ".Domain" - , "import Keiki.Builder ((=:))" - , "import qualified Keiki.Builder as B" - , "import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))" - , holeUpcasterImports a - , holeProjectionImports a - , "" - , "-- HOLE: the transducer body. Reproduce the structure below, replacing each" - , "-- `-- HOLE` line with the keiki symbolic operators it describes." - , lowerFirst (aName a) <> "Transducer" - , " :: SymTransducer" - , " (HsPred " <> aName a <> "Regs " <> aName a <> "Command)" - , " " <> aName a <> "Regs" - , " " <> aVertexType a - , " " <> aName a <> "Command" - , " " <> aName a <> "Event" - , lowerFirst (aName a) <> "Transducer =" - , " B.buildTransducer " <> initialVertex a <> " initial" <> aName a <> "Regs isTerminal do" - , nl (concatMap (fromBlock a) (groupBySource a)) - , " where" - , " isTerminal = \\case" - , nl [" " <> vertexCtor a (stName s) <> " -> True" | s <- aStates a, stTerminal s] - , " _ -> False" - , holeProjectionStub a - , holeUpcasterStubs a - ] - --- | Export, import, and stub the per-event upcaster holes (EP-2 evolution). -holeUpcasterExports :: Agg -> Text -holeUpcasterExports a = case upcasterEntries a of - [] -> "" - es -> nl [" , " <> fn | (_, fn) <- es] - -holeUpcasterImports :: Agg -> Text -holeUpcasterImports a = case upcasterEntries a of - [] -> "" - _ -> nl ["import Data.Aeson (Value)", "import Data.Text (Text)"] - -holeUpcasterStubs :: Agg -> Text -holeUpcasterStubs a = case upcasterEntries a of - [] -> "" - es -> - nl $ - concat - [ [ "" - , "-- HOLE upcaster: bring a " <> fn <> " payload up one version. Decide the" - , "-- default/derivation for any field added at the new version here." - , fn <> " :: Value -> Either Text Value" - , fn <> " _ = Left \"HOLE: upcaster not implemented\"" - ] - | (_, fn) <- es - ] - -holeProjectionExport :: Agg -> Text -holeProjectionExport a = case aProjection a of - Nothing -> " -- (no projection)" - Just p -> " , apply" <> pascal (projTable p) - -holeProjectionImports :: Agg -> Text -holeProjectionImports aggregate = case projectionReadModel aggregate of - Nothing -> "" - Just readModel -> - "import " - <> genPrefixFor (aContext aggregate) (pascal (rmName readModel)) - <> ".ReadModelTable (" - <> readModelStem readModel - <> "QualifiedTable)" - -holeProjectionStub :: Agg -> Text -holeProjectionStub a = case aProjection a of - Nothing -> "" - Just p -> - nl - ( [ "" - , "-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the" - , "-- pure event->status mapping is generated as " <> lowerFirst (projTable p) <> "StatusFor)." - ] - ++ projectionGuidance - ++ [ "apply" <> pascal (projTable p) <> " :: " <> aName a <> "Event -> recorded -> txn ()" - , "apply" <> pascal (projTable p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> projTable p <> " projection apply\"" - ] - ) - where - projectionGuidance = case projectionReadModel a of - Nothing -> - ["-- WARNING: no readmodel node declares this table's schema; unqualified SQL depends on search_path."] - Just readModel -> - [ "-- Table: " <> qualifiedTableLiteral readModel <> ". Use " <> readModelStem readModel <> "QualifiedTable; never rely on search_path." - , "-- Declared columns:" - ] - ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) - projectionTableUse = case projectionReadModel a of - Nothing -> "" - Just readModel -> readModelStem readModel <> "QualifiedTable `seq` " - --- Group transitions by source state, preserving order, for the B.from blocks. -groupBySource :: Agg -> [(Text, [Transition])] -groupBySource a = go [] (transitionsOf a) - where - go acc [] = reverse acc - go acc (t : ts) = - let src = tSource t - (same, rest) = span ((== src) . tSource) ts - in go ((src, t : same) : acc) rest - --- We don't keep the original Aggregate around in Agg, so reconstruct --- transitions from a stored field. (Filled in resolveAgg via aTransitions.) -transitionsOf :: Agg -> [Transition] -transitionsOf = aTransitions - -fromBlock :: Agg -> (Text, [Transition]) -> [Text] -fromBlock a (src, ts) = - [ " B.from " <> vertexCtor a src <> " do" - ] - ++ concatMap (onCmdBlock a) ts - -onCmdBlock :: Agg -> Transition -> [Text] -onCmdBlock a t = - [ " B.onCmd inCtor" <> tCommand t <> " $ \\d -> B.do" - ] - ++ maybe [] (\g -> [" -- HOLE guard: " <> renderGuard g]) (tGuard t) - ++ [" -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- tWrites t] - ++ [" -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- tEmits t] - ++ [" B.goto " <> vertexCtor a (tGoto t)] - --------------------------------------------------------------------------------- --- Field categories and shared helpers --------------------------------------------------------------------------------- - -data FieldCat = IdCat | EnumCat | OtherCat - -fieldCat :: Agg -> Text -> FieldCat -fieldCat a ty - | ty `elem` map idName (aIds a) = IdCat - | ty `elem` map enumName (aEnums a) = EnumCat - | otherwise = OtherCat - --- | The first constructor of a declared enum, used to build sample values. -firstEnumCtor :: Agg -> Text -> Maybe Text -firstEnumCtor a ty = - case [c | e <- aEnums a, enumName e == ty, (c, _) <- take 1 (enumCtors e)] of - (c : _) -> Just c - [] -> Nothing - -vertexCtor :: Agg -> Text -> Text -vertexCtor a s = aName a <> s - -initialVertex :: Agg -> Text -initialVertex a = case aStates a of - (s : _) -> vertexCtor a (stName s) - [] -> aName a <> "Init" - -generatedBanner :: Text -generatedBanner = "-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec." - -nodeOrigin :: Text -> Text -> Loc -> Text -nodeOrigin nodeKind nodeName loc = - nodeKind <> " " <> nodeName <> case unLoc loc of - 0 -> "" - line -> " (line " <> tshow' line <> ")" - -{- | Conditions that the deterministic emitters cannot lower faithfully. The -pre-write scaffold pipeline treats each returned message as a refusal. The -list is extended alongside the policy and type lowering milestones. --} -scaffoldRefusals :: Spec -> [Text] -scaffoldRefusals spec = - concatMap aggregateRefusals aggregates - <> concatMap contractRefusals contracts - <> concatMap publisherRefusals publishers - where - aggregates = [aggregate | NAggregate aggregate <- specNodes spec] - contracts = [contract | NContract contract <- specNodes spec] - publishers = [publisher | NPublisher publisher <- specNodes spec] - idTypes = map idName (specIds spec) - enumTypes = map enumName (specEnums spec) - enumCtorsFor ty = case [map fst (enumCtors enum) | enum <- specEnums spec, enumName enum == ty] of - ctors : _ -> ctors - [] -> [] - aggregateRefusals aggregate = - [ "AggregateEmpty: aggregate '" <> aggName aggregate <> "' must declare at least one command, event, and transition" - | null (aggCommands aggregate) || null (aggEvents aggregate) || null (aggTransitions aggregate) - ] - <> concatMap (registerRefusals aggregate) (aggRegs aggregate) - <> [ "FieldTypeUnrepresentable: aggregate '" <> aggName aggregate <> "' field '" <> fieldName field <> "' has unsupported explicit type '" <> ty <> "'" - | field <- aggregateFields aggregate - , Just ty <- [fieldType field] - , not (supportedType aggregate ty) - ] - registerRefusals aggregate reg = - [ "RegTypeUnsupported: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' has unsupported type '" <> regType reg <> "'" - | not (supportedType aggregate (regType reg)) - ] - <> [ "RegTextInitialNotQuoted: aggregate '" <> aggName aggregate <> "' Text register '" <> regName reg <> "' must use a quoted initial" - | regType reg == "Text" - , RegInitBare _ <- [regInitial reg] - ] - <> [ "RegInitialNotEnumCtor: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' must start at a constructor of enum '" <> regType reg <> "'" - | regType reg `elem` enumTypes - , case regInitial reg of - RegInitBare value -> value `notElem` enumCtorsFor (regType reg) - RegInitText _ -> True - ] - <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Bool register '" <> regName reg <> "' must start at True or False" - | regType reg == "Bool" - , case regInitial reg of RegInitBare value -> value `notElem` ["True", "False"]; RegInitText _ -> True - ] - <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Int register '" <> regName reg <> "' must start at an integer literal" - | regType reg == "Int" - , case regInitial reg of RegInitBare value -> (readMaybe (T.unpack value) :: Maybe Int) == Nothing; RegInitText _ -> True - ] - aggregateFields aggregate = - concatMap cmdFields (aggCommands aggregate) - <> concat [fields | event <- aggEvents aggregate, EventFields fields <- [evBody event]] - supportedType aggregate ty = - ty `elem` (["Text", "Int", "Bool", aggName aggregate <> "Vertex"] <> idTypes <> enumTypes) + scaffoldReplayAudit, + scaffoldStructural, + codecComparisonModule, + codecComparisonBanner, + bindingSkeletonModules, + scaffoldAggregate, + scaffoldProcess, + scaffoldRouter, + scaffoldContract, + scaffoldIntake, + scaffoldPublisher, + scaffoldWorkqueue, + scaffoldReadModel, + scaffoldRefusals, + windowSeconds, + + -- * Firewall self-check (M3) + FirewallSurface (..), + firewallSurface, + firewallBreaches, + + -- * Internal resolution, shared with "Keiro.Dsl.Harness" + Agg (..), + ResolvedCtor (..), + StructuralProjection (..), + resolveAgg, + projectionSpecs, + resolveProjectionModules, + codecMappedDeclarations, + FieldCat (..), + fieldCat, + vertexCtor, + initialVertex, + firstEnumCtor, + lowerFirst, + pascal, + pascalFromKebab, + generatedBanner, +) where + +import Data.Char (isAlpha, isAlphaNum, isUpper, ord, toLower, toUpper) +import Data.List (find, groupBy, nub, sort, sortOn) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..)) +import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations) +import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint) +import Keiro.Dsl.Grammar +import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor) +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (sagaCategoryError) +import Numeric (showHex) +import Text.Read (readMaybe) + +{- | One emitted module: its on-disk path (relative to the scaffold @--out@ +directory), its full text, and whether it is overwritten every run +('Generated') or written only when absent ('HoleStub'). +-} +data ScaffoldModule = ScaffoldModule + { modulePath :: !FilePath + , moduleText :: !Text + , kind :: !ModuleKind + , origin :: !Text + } + deriving stock (Eq, Show) + +data ModuleKind + = -- | @-- \@generated@; overwritten on every scaffold. + Generated + | -- | Hand-owned; created only when absent, never overwritten. + HoleStub + deriving stock (Eq, Show) + +{- | The threading context: the spec's @context@ name, the chosen output +module-namespace root, and the placement style. Extended additively (never +re-shaped) by later verticals. +-} +data Context = Context + { contextName :: !Text + , moduleRoot :: !Text + -- ^ @""@ means no namespace prefix (the historical default). + , placement :: !Placement + -- ^ 'GeneratedPrefix' is the historical default. + } + deriving stock (Eq, Show) + +{- | A context with today's default placement ('GeneratedPrefix', no root prefix) +for the given @context@ name. Callers that do not care about placement (the +@parse@ path, tests) build their context with this. +-} +defaultContext :: Text -> Context +defaultContext name = Context{contextName = name, moduleRoot = "", placement = GeneratedPrefix} + +{- | The generated-layer namespace for a node, honouring the root prefix and the +placement style. The 'Text' argument is the already-pascalised node name (e.g. +@Reservation@, @HospitalSurge@). For 'GeneratedPrefix' this is +@\.Generated.\.\@ (identical to the historical layout); for +'CollocatedLeaf' it is @\.\.\.Generated@. +-} +genPrefixFor :: Context -> Text -> Text +genPrefixFor ctx node = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> "." <> node + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> "." <> node <> ".Generated" + +{- | The hand-owned (hole) namespace for a node: @\.\.\@ — +the same for both placement styles (holes always sit beside the domain). +-} +holePrefixFor :: Context -> Text -> Text +holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node + +-- | The root namespace prefix, dot-terminated, or @""@ when no root is set. +rootPrefix :: Context -> Text +rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "." + +-- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@. +ctxPascalOf :: Context -> Text +ctxPascalOf = pascalFromKebab . contextName + +-------------------------------------------------------------------------------- +-- Firewall self-check (M3) +-------------------------------------------------------------------------------- + +{- | The canonical keiki surface forbidden in generated modules. Symbolic +operators are matched as maximal Haskell symbol tokens, identifiers as complete +tokens, qualifiers by their leading module alias, and imports structurally. +-} +data FirewallSurface = FirewallSurface + { forbiddenSymbolic :: ![Text] + , forbiddenIdents :: ![Text] + , forbiddenQualifiers :: ![Text] + , forbiddenImports :: ![Text] + , restrictedImports :: ![(Text, [Text])] + } + deriving stock (Eq, Show) + +firewallSurface :: FirewallSurface +firewallSurface = + FirewallSurface + { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"] + , forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"] + , forbiddenQualifiers = ["B"] + , forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"] + , -- Generated aggregate modules use the first two names; generated + -- harnesses validate, step, and replay filled holes register by register. + restrictedImports = + [ + ( "Keiki.Core" + , + [ "RegFile" + , "HsPred" + , "FieldProjection" + , "FieldWitness" + , "fieldWitness" + , "fieldWitnessAgrees" + , "applyEventsEither" + , "defaultValidationOptions" + , "step" + , "validateTransducer" + , "!" + ] + ) + ] + } + +{- | Scan generated modules for firewall breaches, returning every offending +@(module path, token, 1-based line number)@. Only modules whose 'kind' is +'Generated' are scanned. Strings and comments are skipped, symbol runs use +maximal munch, and keiki imports are checked independently of token spelling. +-} +firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)] +firewallBreaches mods = + [ (modulePath m, breach, n) + | m <- mods + , kind m == Generated + , (n, line) <- zip [1 ..] (T.lines (moduleText m)) + , breach <- lineBreaches line + ] + +lineBreaches :: Text -> [Text] +lineBreaches line = case importModule line of + Just _ -> importBreaches line + Nothing -> tokenBreaches (codeTokens line) + where + tokenBreaches = mapMaybe breachFor + breachFor (IdentToken ident) + | ident `elem` forbiddenIdents firewallSurface = Just ident + breachFor (QualifiedToken qualifier) + | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*") + breachFor (SymbolToken symbol) + | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol + breachFor _ = Nothing + +data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text + +codeTokens :: Text -> [CodeToken] +codeTokens = go . T.unpack + where + go [] = [] + go ('-' : '-' : _) = [] + go ('"' : rest) = go (dropString rest) + go ('\'' : rest) = go (dropChar rest) + go (c : rest) + | isIdentStart c = + let (identTail, afterIdent) = span isIdentContinue rest + ident = T.pack (c : identTail) + in case afterIdent of + '.' : next : more + | isUpper c && isIdentStart next -> + let (_member, afterMember) = span isIdentContinue more + in QualifiedToken ident : go afterMember + _ -> IdentToken ident : go afterIdent + | isSymbolChar c = + let (symbolTail, afterSymbol) = span isSymbolChar rest + in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol + | otherwise = go rest + isIdentStart c = isAlpha c || c == '_' + isIdentContinue c = isAlphaNum c || c == '_' || c == '\'' + isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) + dropString [] = [] + dropString ('\\' : _escaped : rest) = dropString rest + dropString ('"' : rest) = rest + dropString (_ : rest) = dropString rest + dropChar [] = [] + dropChar ('\\' : _escaped : rest) = dropChar rest + dropChar ('\'' : rest) = rest + dropChar (_ : rest) = dropChar rest + +importBreaches :: Text -> [Text] +importBreaches line = case importModule line of + Nothing -> [] + Just imported + | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported] + | Just allowed <- lookup imported (restrictedImports firewallSurface) + , not (hasAllowedExplicitImportList allowed line) -> + ["import:" <> imported] + | otherwise -> [] + +importModule :: Text -> Maybe Text +importModule line = case T.words (T.strip line) of + "import" : rest -> find (T.isPrefixOf "Keiki.") rest + _ -> Nothing + +hasAllowedExplicitImportList :: [Text] -> Text -> Bool +hasAllowedExplicitImportList allowed line = + case (T.breakOn "(" line, T.breakOnEnd ")" line) of + ((_, open), (close, _)) + | not (T.null open) && not (T.null close) -> + let inside = T.takeWhile (/= ')') (T.drop 1 open) + names = filter (not . T.null) (T.split (not . isAlphaNum) inside) + in all (`elem` allowed) names + _ -> False + +-------------------------------------------------------------------------------- +-- Derived naming +-------------------------------------------------------------------------------- + +-- | Resolved, denormalized view of an aggregate used by every emitter. +data Agg = Agg + { aContext :: !Context + , aCtxPascal :: !Text + , aName :: !Text + , aLoc :: !Loc + , aVertexType :: !Text + , aIds :: ![IdDecl] + , aEnums :: ![EnumDecl] + , aRegs :: ![RegDecl] + , aStates :: ![StateDecl] + , aCommands :: ![ResolvedCtor] + , aEvents :: ![ResolvedCtor] + , aTransitions :: ![Transition] + , aWire :: !WireSpec + , aProjection :: !(Maybe ProjectionSpec) + , aSnapshot :: !(Maybe SnapshotSpec) + , aFoldFingerprint :: !Text + , aReadModels :: ![ReadModelNode] + , aTypeGraph :: !(Maybe TypeGraph) + , aGenPrefix :: !Text + -- ^ e.g. @Generated.HospitalCapacity.Reservation@ + , aHolePrefix :: !Text + -- ^ e.g. @HospitalCapacity.Reservation@ + } + +-- | A command or event constructor with its fully-resolved field types. +data ResolvedCtor = ResolvedCtor + { rcName :: !Text + , rcFields :: ![(Text, Text)] + -- ^ (field name, resolved Haskell type) + , rcVersion :: !Int + -- ^ EP-2: schema version (1 for commands and unversioned events). + , rcUpcastFrom :: !(Maybe Int) + -- ^ EP-2: the source version this event migrates from (the upcaster step). + } + +defaultWire :: WireSpec +defaultWire = WireSpec{wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1} + +resolveAgg :: Context -> Spec -> Aggregate -> Agg +resolveAgg ctx spec agg = + Agg + { aContext = ctx + , aCtxPascal = ctxPascal + , aName = nm + , aLoc = aggLoc agg + , aVertexType = vertexType + , aIds = specIds spec + , aEnums = specEnums spec + , aRegs = aggRegs agg + , aStates = aggStates agg + , aCommands = map resolveCommand (aggCommands agg) + , aEvents = map resolveEvent (aggEvents agg) + , aTransitions = aggTransitions agg + , aWire = fromMaybe defaultWire (aggWire agg) + , aProjection = aggProjection agg + , aSnapshot = aggSnapshot agg + , aFoldFingerprint = aggregateFoldFingerprint spec agg + , aReadModels = [readModel | NReadModel readModel <- specNodes spec] + , aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec) + , aGenPrefix = genPrefixFor ctx nm + , aHolePrefix = holePrefixFor ctx nm + } + where + nm = aggName agg + ctxPascal = pascalFromKebab (contextName ctx) + vertexType = nm <> "Vertex" + commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg] + resolveCommand c = (mkCtor (cmdName c) (cmdFields c)){rcVersion = 1, rcUpcastFrom = Nothing} + resolveEvent e = + (mkCtor (evName e) (eventFields e)) + { rcVersion = evVersion e + , rcUpcastFrom = fst <$> evUpcastFrom e + } + where + eventFields ev = case evBody ev of + EventFields fs -> fs + EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes) + mkCtor cn fs = + ResolvedCtor + { rcName = cn + , rcFields = map (\f -> (fieldName f, resolveFieldType f)) fs + , rcVersion = 1 + , rcUpcastFrom = Nothing + } + regTypes = [(regName r, regType r) | r <- aggRegs agg] + idNames = map idName (specIds spec) + enumNames = map enumName (specEnums spec) + -- A bare field reuses a register's type if one shares its name; else it + -- Pascal-cases to a declared id/enum/vertex; else falls back to Text. + resolveFieldType f = case fieldType f of + Just ty -> ty + Nothing -> + let nme = fieldName f + pas = pascal nme + in case lookup nme regTypes of + Just ty -> ty + Nothing + | pas `elem` idNames -> pas + | pas `elem` enumNames -> pas + | pas == vertexType -> pas + | otherwise -> "Text" + +-------------------------------------------------------------------------------- +-- Entry point +-------------------------------------------------------------------------------- + +{- | Emit the context-level private structural stratum. Shape modules contain +only generated wire representations. The projection facade contains only +schema-derived Keiki field witnesses; neither layer owns consumer behavior. +-} +scaffoldStructural :: Context -> Spec -> [ScaffoldModule] +scaffoldStructural ctx spec = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> map (shapeModule ctx graph) structural <> projectionModules <> bindingSkeletonModules ctx spec graph + where + structural = + [ (declaration, shape) + | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) + ] + projectionModules = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs") + , moduleText = emitStructuralProjections ctx graph + , kind = Generated + , origin = "context " <> specContext spec <> " mapped structural facade" + } + | not (null (projectionSpecs graph)) + ] + +{- | Plan one opt-in, non-production historical-codec comparison module. + +The module is intentionally absent from 'scaffoldStructural' and therefore +from production manifests and scaffold records. It must be requested by name +and is compiled only by consumer-owned test/tool components. +-} +codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule +codecComparisonModule ctx spec requestedName = do + graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec) + (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of + Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName) + Just (ResolvedOpaque _) -> + Left + ( "codec comparison target " + <> requestedName + <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim" + ) + Just (ResolvedStructural declaration shape) -> Right (declaration, shape) + owner <- case sortOn aggName (comparisonOwners declaration) of + [] -> + Left + ( "codec comparison target " + <> requestedName + <> " is not reachable from a persisted private event payload" + ) + aggregate : _ -> Right aggregate + let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName + pure + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs") + , moduleText = emitCodecComparison ctx moduleName graph declaration shape owner + , kind = Generated + , origin = "non-production codec comparison " <> requestedName + } + where + comparisonOwners declaration = + [ aggregate + | NAggregate aggregate <- specNodes spec + , let resolved = resolveAgg ctx spec aggregate + , any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved) + ] + where + mappedName (ResolvedStructural structural _) = sdName structural + mappedName (ResolvedOpaque opaque) = odName opaque + +codecComparisonBanner :: Text +codecComparisonBanner = + "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit." + +emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text +emitCodecComparison ctx moduleName graph declaration shape owner = + nl + [ "{-# LANGUAGE ImportQualifiedPost #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "" + , codecComparisonBanner + , "-- This module compares historical and generated codecs in consumer-owned tests only." + , "-- It is never a runtime fallback and never changes the generated codec's authority." + , "module " <> moduleName <> " (compareWithHistorical) where" + , "" + , "import Control.Monad (filterM)" + , "import Data.Aeson (Value)" + , "import Data.Aeson qualified as Aeson" + , "import Data.List (sort)" + , "import Data.List.NonEmpty qualified as NonEmpty" + , "import Data.Text (Text)" + , "import Data.Text qualified" + , "import " <> codecModule <> " qualified as GeneratedCodec" + , "import Keiro.Codec.Structural (FixtureCases (..))" + , "import Keiro.Dsl.CodecCompare" + , "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))" + , "import System.Directory (doesFileExist, listDirectory)" + , "import System.FilePath (takeExtension, ())" + , "" + , "import " <> fixtureModule <> " qualified as ConsumerFixtures" + , "import " <> hsModule (sdHaskell declaration) <> " qualified as ConsumerDomain" + , "" + , "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport" + , "compareWithHistorical historicalCodec goldenDirectory = do" + , " names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory" + , " files <- filterM doesFileExist [goldenDirectory name | name <- names]" + , " loaded <- traverse (loadGolden historicalCodec) files" + , " let inputIssues = [issue | Left issue <- loaded]" + , " entries = [entry | Right entry <- loaded]" + , " typedCases = NonEmpty.toList (fixtureCases ConsumerFixtures." <> fixtureSymbol <> ")" + , " encodeObservations =" + , " [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)" + , " | (label, value) <- typedCases" + , " ]" + , " decodeObservations = [observation | (observation, _) <- entries]" + , " typedObserved =" + , " concat" + , " [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)" + , " | (_, value) <- typedCases" + , " ]" + , " historicalObserved =" + , " concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]" + , " declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema" + , " provenance =" + , " CompareProvenance" + , " { cpHistoricalCodecIdentity = hcIdentity historicalCodec" + , " , cpHistoricalCodecVersion = hcVersion historicalCodec" + , " , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)) + , " , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)) + , " , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)) + , " , cpWireFingerprint = " <> tshow (wireFingerprint graph name) + , " }" + , " pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))" + , "" + , "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))" + , "loadGolden historicalCodec path = do" + , " decoded <- Aeson.eitherDecodeFileStrict path" + , " pure $ case decoded of" + , " Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))" + , " Right inputValue ->" + , " let historicalDecoded = hcDecode historicalCodec inputValue" + , " historicalOutcome = normalizeDecode historicalDecoded" + , " generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)" + , " observation = DecodeObservation path inputValue historicalOutcome generatedOutcome" + , " coveredValues = case historicalDecoded of" + , " Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]" + , " Left _ -> []" + , " in Right (observation, coveredValues)" + , "" + , "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome" + , "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)" + , "" + , "fromString :: String -> Text" + , "fromString = Data.Text.pack" + , "" + , "branchSchema :: BranchSchema" + , "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape)) + ] + where + name = sdName declaration + domainType = "ConsumerDomain." <> hsType (sdHaskell declaration) + codecModule = genPrefixFor ctx (aggName owner) <> ".Codec" + fixtureModule = qualifiedModule (sdFixtures declaration) + fixtureSymbol = lastSegment (unQualifiedValueName (sdFixtures declaration)) + +branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema +branchSchemaFor graph = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + BranchRecord + [ BranchField + (rwfKey field) + (rwfPresence field == POptional) + (branchExpr graph (rwfType field)) + | field <- fields + ] + , onEnum = const BranchScalar + , onUnion = \encoding arms -> + BranchUnion + (ueTagField encoding) + (ueContentsField encoding) + [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms] + } + shape + , onOpaqueDecl = const BranchScalar + } + +branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema +branchExpr graph = + foldTypeExpr + TypeExprAlgebra + { onText = BranchScalar + , onInt = BranchScalar + , onBool = BranchScalar + , onNatural = BranchScalar + , onTime = BranchScalar + , onJson = BranchScalar + , onOptional = BranchOptional + , onList = BranchList + , onMap = BranchMap + , onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph)) + } + +renderBranchSchema :: BranchSchema -> Text +renderBranchSchema schema = case schema of + BranchScalar -> "BranchScalar" + BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")" + BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")" + BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")" + BranchRecord fields -> + "BranchRecord [" + <> T.intercalate + ", " + [ "BranchField " + <> tshow (bfWireKey field) + <> " " + <> (if bfPresenceOptional field then "True" else "False") + <> " (" + <> renderBranchSchema (bfSchema field) + <> ")" + | field <- fields + ] + <> "]" + BranchUnion tagField contentsField arms -> + "BranchUnion " + <> tshow tagField + <> " " + <> tshow contentsField + <> " [" + <> T.intercalate + ", " + [ "BranchArm " + <> tshow (baWireTag arm) + <> " " + <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm) + | arm <- arms + ] + <> "]" + +{- | Emit one create-once consumer module per distinct qualified obligation +owner. Multiple mapped declarations may intentionally share a leaf binding +module, so grouping happens by module rather than by declaration. +-} +bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule] +bindingSkeletonModules ctx spec graph = case bindingObligations spec of + Left _ -> [] + Right obligations -> + [ emitBindingSkeleton ctx graph owner entries + | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations]) + ] + +emitBindingSkeleton :: Context -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule +emitBindingSkeleton ctx graph owner obligations = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" owner <> ".hs") + , moduleText = + nl $ + [ "{-# LANGUAGE LambdaCase #-}" + , "" + , "-- This is a HAND-OWNED structural binding skeleton. keiro-dsl creates it once" + , "-- and never overwrites it. Fill each HOLE and run the generated harness." + , "module " <> owner <> " (" + ] + <> exportLines + <> [") where", ""] + <> map ("import " <>) imports + <> [""] + <> intercalateBlank (map renderObligation obligations) + , kind = HoleStub + , origin = "mapped structural binding skeleton " <> owner + } + where + exportLines = + [ (if index == (0 :: Int) then " " else " , ") <> obligationSymbol obligation + | (index, obligation) <- zip [0 ..] obligations + ] + imports = + sort . nub $ + [ hsModule (sdHaskell declaration) <> " qualified" + | obligation <- obligations + , Just (declaration, _) <- [structuralFor obligation] + ] + <> [ structuralShapeModule ctx (sdName declaration) <> " qualified" + | obligation <- obligations + , obligationKind obligation == BindingValue + , Just (declaration, _) <- [structuralFor obligation] + ] + <> [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))" + | any ((`elem` [BindingValue, FixtureValue]) . obligationKind) obligations + ] + renderObligation obligation = case structuralFor obligation of + Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"] + Just (declaration, shape) -> case obligationKind obligation of + BindingValue -> renderBinding ctx declaration shape obligation + FixtureValue -> + [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration + , obligationSignature obligation + , obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures") + ] + InitialValue -> + [ "-- HOLE: provide the initial register value for " <> sdName declaration + , obligationSignature obligation + , obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value") + ] + structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of + Just (ResolvedStructural declaration shape) -> Just (declaration, shape) + _ -> Nothing + intercalateBlank [] = [] + intercalateBlank (section : rest) = section <> concatMap ("" :) rest + +renderBinding :: Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text] +renderBinding ctx declaration shape obligation = + [ "-- HOLE: complete both total directions; wire policy remains in the generated codec." + , obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType + , obligationSymbol obligation <> " =" + , " StructuralBinding" + , " { bindingToShape = \\case" + ] + <> indentCases (bindingCases True) + <> [" , bindingFromShape = \\case"] + <> indentCases (bindingCases False) + <> [" }"] + where + domainModule = hsModule (sdHaskell declaration) + domainType = domainModule <> "." <> hsType (sdHaskell declaration) + shapeModuleName = structuralShapeModule ctx (sdName declaration) + shapeType = shapeModuleName <> "." <> sdName declaration <> "Shape" + domainCtor constructor = domainModule <> "." <> constructor + shapeCtor constructor = shapeModuleName <> "." <> constructor + indentCases = map (" " <>) + bindingCases toShapeDirection = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields] + , onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries + , onUnion = \_ arms -> map (unionCase toShapeDirection) arms + } + shape + recordCase toShapeDirection constructor fields = + sourceCtor + <> arguments variables + <> " -> " + <> targetCtor + <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields) + where + variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields + sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor + targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor + enumCase toShapeDirection constructor = + sourceCtor <> " -> " <> holeFor toShapeDirection constructor + where + sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor + unionCase toShapeDirection arm = + sourceCtor + <> maybe "" (const " _payloadValue") (rwaPayload arm) + <> " -> " + <> case rwaPayload arm of + Nothing -> holeFor toShapeDirection (rwaCtor arm) + Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload") + where + sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm) + targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm) + arguments [] = "" + arguments values = " " <> T.unwords values + holeFor toShapeDirection fieldName = + "(error " + <> tshow + ( "HOLE: fill " + <> sdName declaration + <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.") + <> fieldName + ) + <> ")" + +shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule +shapeModule ctx graph (declaration, shape) = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs") + , moduleText = emitShape ctx graph declaration shape + , kind = Generated + , origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration) + } + +structuralPrefix :: Context -> Text +structuralPrefix ctx = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural" + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural" + +structuralShapeModule :: Context -> Name -> Text +structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name + +structuralProjectionModule :: Context -> Text +structuralProjectionModule ctx = structuralPrefix ctx <> "Projections" + +emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShape ctx graph declaration shape = + nl $ + languagePragmas + <> [ generatedBanner + , "module " <> moduleName <> " (" <> shapeType <> " (..)) where" + , "" + ] + <> map ("import " <>) imports + <> ["" | not (null imports)] + <> [shapeDeclaration] + where + moduleName = structuralShapeModule ctx (sdName declaration) + shapeType = sdName declaration <> "Shape" + requirements = shapeRequirements ctx graph shape + languagePragmas = + ["{-# LANGUAGE DeriveGeneric #-}"] + <> ["{-# LANGUAGE DuplicateRecordFields #-}" | shapeHasRecord shape] + imports = + sort . nub $ + ["Data.Aeson (Value)" | ReqJson `elem` requirements] + <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements] + <> ["Data.Text (Text)" | ReqText `elem` requirements] + <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements] + <> ["GHC.Generics (Generic)"] + <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements] + <> [m <> " qualified" | ReqModule m <- requirements] + shapeDeclaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> + nl $ + ["data " <> shapeType <> " = " <> constructor] + <> recordFields + [ (rwfHaskell field, renderShapeType ctx graph (rwfType field)) + | field <- fields + ] + <> [" deriving stock (Eq, Generic, Show)"] + , onEnum = \entries -> + "data " + <> shapeType + <> " = " + <> T.intercalate " | " (map weCtor entries) + <> "\n deriving stock (Eq, Generic, Show)" + , onUnion = \_ arms -> + nl $ + case arms of + [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", " deriving stock (Eq, Generic, Show)"] + firstArm : rest -> + ["data " <> shapeType <> " = " <> renderArm firstArm] + <> [" | " <> renderArm arm | arm <- rest] + <> [" deriving stock (Eq, Generic, Show)"] + } + shape + renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType ctx graph) (rwaPayload arm) + +data ShapeRequirement + = ReqJson + | ReqMap + | ReqText + | ReqTime + | ReqNatural + | ReqModule !Text + deriving stock (Eq, Ord, Show) + +shapeHasRecord :: ResolvedMappedShape -> Bool +shapeHasRecord = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ _ -> True + , onEnum = const False + , onUnion = \_ _ -> False + } + +shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement] +shapeRequirements ctx graph = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields + , onEnum = const [] + , onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms + } + +exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement] +exprRequirements ctx graph = + foldTypeExpr + TypeExprAlgebra + { onText = [ReqText] + , onInt = [] + , onBool = [] + , onNatural = [ReqNatural] + , onTime = [ReqTime] + , onJson = [ReqJson] + , onOptional = id + , onList = id + , onMap = (ReqMap :) . (ReqText :) + , onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> [ReqModule (structuralShapeModule ctx (sdName declaration))] + Just (ResolvedOpaque declaration) -> [ReqModule (hsModule (odHaskell declaration))] + Nothing -> [] + } + +renderShapeType :: Context -> TypeGraph -> ResolvedTypeExpr -> Text +renderShapeType ctx graph = + foldTypeExpr + TypeExprAlgebra + { onText = "Text" + , onInt = "Int" + , onBool = "Bool" + , onNatural = "Natural" + , onTime = "UTCTime" + , onJson = "Value" + , onOptional = \value -> "(Maybe (" <> value <> "))" + , onList = \value -> "([" <> value <> "])" + , onMap = \value -> "(Map Text (" <> value <> "))" + , onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> + structuralShapeModule ctx (sdName nested) <> "." <> sdName nested <> "Shape" + Just (ResolvedOpaque opaque) -> + hsModule (odHaskell opaque) <> "." <> hsType (odHaskell opaque) + Nothing -> "()" + } + +data StructuralProjection = StructuralProjection + { spTag :: !Text + , spWitness :: !Text + , spPointer :: !Text + , spOwner :: !HaskellSource + , spResult :: !Text + , spCanonical :: !CanonicalTypeId + , spBinding :: !QualifiedValueName + , spSelectors :: ![(Text, Text)] + } + deriving stock (Eq, Show) + +projectionSpecs :: TypeGraph -> [StructuralProjection] +projectionSpecs graph = + sortOn spTag . concat $ + [ projectionsForRoot graph declaration shape + | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) + ] + +projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection] +projectionsForRoot graph root rootShape = case rootShape of + RRecord _ _ fields -> concatMap (walkField [] []) fields + REnum{} -> [] + RUnion{} -> [] + where + walkField keys selectors field + | rwfPresence field /= PRequired = [] + | otherwise = case projectionScalar (rwfType field) of + Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result] + Nothing -> case rwfType field of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested (RRecord _ _ nestedFields)) -> + concatMap + (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)])) + nestedFields + _ -> [] + _ -> [] + where + shapeModuleForOwner = "__SHAPE__." <> sdName root + + walkNested owner keys selectors field + | rwfPresence field /= PRequired = [] + | otherwise = case projectionScalar (rwfType field) of + Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result] + Nothing -> case rwfType field of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested (RRecord _ _ nestedFields)) -> + concatMap + (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)])) + nestedFields + _ -> [] + _ -> [] + + -- Context is supplied when rendering; this marker is replaced there. + shapeModuleFor declaration = "__SHAPE__." <> sdName declaration + mkProjection keys selectors result = + StructuralProjection + { spTag = projectionTag (sdName root) pointer + , spWitness = lowerFirst (projectionTag (sdName root) pointer) <> "Witness" + , spPointer = pointer + , spOwner = sdHaskell root + , spResult = result + , spCanonical = sdCanonical root + , spBinding = sdBinding root + , spSelectors = selectors + } + where + pointer = T.concat ["/" <> escapePointer key | key <- keys] + +projectionScalar :: ResolvedTypeExpr -> Maybe Text +projectionScalar = \case + RText -> Just "Text" + RInt -> Just "Int" + RBool -> Just "Bool" + RTime -> Just "UTCTime" + RNatural -> Nothing + RJson -> Nothing + ROptional{} -> Nothing + RList{} -> Nothing + RMap{} -> Nothing + RRef{} -> Nothing + +escapePointer :: Text -> Text +escapePointer = T.replace "/" "~1" . T.replace "~" "~0" + +projectionTag :: Name -> Text -> Text +projectionTag owner pointer = "StructuralProjection" <> encodeIdentifier (owner <> pointer) + +encodeIdentifier :: Text -> Text +encodeIdentifier = T.concatMap (\character -> "C" <> T.pack (showHex (ord character) "") <> "Z") + +emitStructuralProjections :: Context -> TypeGraph -> Text +emitStructuralProjections ctx graph = + nl $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , generatedBanner + , "-- Equality witnesses are emitted for Text, Int, Bool, and UTCTime." + , "-- Only Int and UTCTime belong to Keiki's v1 ordered subset." + , "module " <> moduleName + , " ( " <> T.intercalate "\n , " (map spWitness specs) + , " ) where" + , "" + , "import Data.Text (Text)" + , "import Data.Time (UTCTime)" + , "import Keiro.Codec.Structural (bindingToShape)" + , "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)" + ] + <> map ("import " <>) imports + <> concatMap renderProjection specs + where + moduleName = structuralProjectionModule ctx + specs = map (resolveProjectionModules ctx) (projectionSpecs graph) + imports = + sort . nub $ + [hsModule (spOwner spec) <> " qualified" | spec <- specs] + <> [qualifiedModule (spBinding spec) <> " qualified" | spec <- specs] + <> [shapeModuleName <> " qualified" | spec <- specs, (shapeModuleName, _) <- spSelectors spec] + renderProjection spec = + [ "" + , "data " <> spTag spec + , "" + , "instance FieldProjection " <> spTag spec <> " where" + , " type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec) + , " type FieldOwner " <> spTag spec <> " = " <> renderHaskellSource (spOwner spec) + , " type FieldResult " <> spTag spec <> " = " <> spResult spec + , " fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)) + , " projectFieldValue _ owner = " <> renderGetter spec + , "" + , spWitness spec <> " :: FieldWitness " <> spTag spec + , spWitness spec <> " = fieldWitness @" <> spTag spec + ] + renderGetter spec = + foldl + (\value (shapeModuleName, selector) -> shapeModuleName <> "." <> selector <> " (" <> value <> ")") + ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " owner") + (spSelectors spec) + +resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection +resolveProjectionModules ctx spec = + spec + { spSelectors = + [ (replaceModule marker, selector) + | (marker, selector) <- spSelectors spec + ] + } + where + replaceModule marker + | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name + | otherwise = structuralShapeModule ctx (lastSegment marker) + +qualifiedModule :: QualifiedValueName -> Text +qualifiedModule = fst . splitQualified . unQualifiedValueName + +renderHaskellSource :: HaskellSource -> Text +renderHaskellSource source = hsModule source <> "." <> hsType source + +splitQualified :: Text -> (Text, Text) +splitQualified value = + let (prefix, name) = T.breakOnEnd "." value + in (T.dropEnd 1 prefix, name) + +lastSegment :: Text -> Text +lastSegment = snd . T.breakOnEnd "." + +{- | Emit all modules for one aggregate. The 'Spec' is needed for the shared +id\/enum declarations. +-} +scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule] +scaffoldAggregate ctx spec agg = + [ genModule a "Domain" (emitDomain a) + , genModule a "Codec" (emitCodec a) + , genModule a "EventStream" (emitEventStream a) + , genModule a "Projection" (emitProjection a) + , holeModule a (emitHoles a) + ] + where + a = resolveAgg ctx spec agg + +{- | Emit the context-wide replay-audit target assembly. + +There is one existential target per aggregate declaration. Process saga +aggregates are ordinary aggregate nodes referenced by 'SagaRef', so they are +included by the same single source of truth rather than being duplicated from +the process declaration. +-} +scaffoldReplayAudit :: Context -> Spec -> [ScaffoldModule] +scaffoldReplayAudit ctx spec + | null aggregates = [] + | otherwise = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs") + , moduleText = emitReplayAudit + , kind = Generated + , origin = "context " <> specContext spec <> " replay-audit assembly" + } + ] + where + aggregates = [aggregate | NAggregate aggregate <- specNodes spec] + moduleName = contextGeneratedPrefix ctx <> ".ReplayAudit" + contextGeneratedPrefix context = case placement context of + GeneratedPrefix -> rootPrefix context <> "Generated." <> ctxPascalOf context + CollocatedLeaf -> rootPrefix context <> ctxPascalOf context <> ".Generated" + emitReplayAudit = + nl $ + [ "{-# LANGUAGE GADTs #-}" + , generatedBanner + , "--" + , "-- Deployment contract:" + , "-- * replay-neutral diff: no data audit is required;" + , "-- * affected diff: run AuditTargeted with the emitted affected set" + , "-- against a production copy under the candidate binary;" + , "-- * one-time runtime cutover: run AuditFull;" + , "-- * any non-zero audit exit blocks deployment." + , "module " <> moduleName <> " (auditTargets) where" + , "" + ] + ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate + | aggregate <- aggregates + ] + ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)" + , "import Keiro.Stream qualified as Stream" + , "" + , "auditTargets :: [SomeAuditTarget]" + , "auditTargets =" + ] + ++ concat + [ [ if index == (0 :: Int) then " [ SomeAuditTarget" else " , SomeAuditTarget" + , " AuditTarget" + , " { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream" + , " , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category" + , " , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)" + , " }" + ] + | (index, aggregate) <- zip [0 ..] aggregates + , let aggregateName = aggName aggregate + ] + ++ [" ]"] + +genModule :: Agg -> Text -> Text -> ScaffoldModule +genModule a name body = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs") + , moduleText = body + , kind = Generated + , origin = nodeOrigin "aggregate" (aName a) (aLoc a) + } + +holeModule :: Agg -> Text -> ScaffoldModule +holeModule a body = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs") + , moduleText = body + , kind = HoleStub + , origin = nodeOrigin "aggregate" (aName a) (aLoc a) + } + +-------------------------------------------------------------------------------- +-- Integration contract (EP-4): a self-contained payload ADT + codec +-------------------------------------------------------------------------------- + +{- | Emit the deterministic, symbol-free contract layer: a payload ADT +(per-event records), the topic constants, the @messageType@ discriminator, and a +strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it +compiles standalone — the cross-service schema both producer and consumer agree +on. No keiki symbolic operator (firewall holds). +-} +scaffoldContract :: Context -> ContractNode -> [ScaffoldModule] +scaffoldContract ctx c = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs") + , moduleText = emitContractGen genPrefix c + , kind = Generated + , origin = nodeOrigin "contract" (ctrName c) (ctrLoc c) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (ctrName c)) + +emitContractGen :: Text -> ContractNode -> Text +emitContractGen genPrefix c = + nl $ + [ "{-# LANGUAGE DuplicateRecordFields #-}" + , "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" + , generatedBanner + , "module " <> genPrefix <> ".Contract" + , " ( " <> payloadTy <> " (..)" + , nl [" , " <> ceName e <> "Data (..)" | e <- ctrEvents c] + , " , messageTypeOf" + , " , encode" <> payloadTy + , " , parse" <> payloadTy + , " ) where" + , "" + , "import Data.Aeson (Value, object, withObject, (.:), (.=))" + , "import Data.Aeson.Types (Parser, parseEither)" + , "import Data.Text (Text)" + , "import qualified Data.Text as T" + , "" + , "-- topic constants" + ] + ++ [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow t | (alias, t) <- ctrTopics c] + ++ [ "" + , "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")" + ] + ++ [emitPayloadAdt payloadTy (ctrEvents c)] + ++ [ "" + , "messageTypeOf :: " <> payloadTy <> " -> Text" + , "messageTypeOf = \\case" + ] + ++ [" " <> ceName e <> " {} -> " <> tshow (ceName e) | e <- ctrEvents c] + ++ [ "" + , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value" + , "encode" <> payloadTy <> " = \\case" + ] + ++ concatMap encodeArm (ctrEvents c) + ++ [ "" + , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy + , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)" + , " where" + , " go o = do" + , " kind <- o .: " <> tshow (ctrDiscriminator c) <> " :: Parser Text" + , " case kind of" + ] + ++ concatMap decodeArm (ctrEvents c) + ++ [ " _ -> fail \"unknown message type\"" + , "" + , "mapLeftText :: Either String b -> Either Text b" + , "mapLeftText = either (Left . T.pack) Right" + ] + where + payloadTy = pascal (ctrName c) <> "Payload" + encodeArm e = + [ " " <> ceName e <> " payload ->" + , " object" + ] + ++ [lead i kv | (i, kv) <- zip [(0 :: Int) ..] ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : [tshow (cfName f) <> " .= payload." <> cfName f | f <- ceFields e])] + ++ [" ]"] + lead 0 kv = " [ " <> kv + lead _ kv = " , " <> kv + decodeArm e = + [ " " <> tshow (ceName e) <> " ->" + , " " <> ceName e <> " <$> (" <> ceName e <> "Data" <> fieldApps (ceFields e) <> ")" + ] + fieldApps [] = "" + fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (cfName f) | f <- fs] + +emitPayloadAdt :: Text -> [ContractEvent] -> Text +emitPayloadAdt tyName events = + sectionsOf [map dataRecord events, [sumDecl]] + where + hsType CText = "Text" + hsType CInt = "Int" + hsType (CTypeId _) = "Text" + dataRecord e = + "data " + <> ceName e + <> "Data = " + <> ceName e + <> "Data { " + <> T.intercalate ", " [cfName f <> " :: !" <> hsType (cfType f) | f <- ceFields e] + <> " }\n deriving stock (Eq, Show)" + arm e = ceName e <> " !" <> ceName e <> "Data" + sumDecl = case events of + [] -> "data " <> tyName <> " = " <> tyName <> "Empty\n deriving stock (Eq, Show)" + (e : es) -> + nl $ + ["data " <> tyName <> " = " <> arm e] + ++ [" | " <> arm e2 | e2 <- es] + ++ [" deriving stock (Eq, Show)"] + +-------------------------------------------------------------------------------- +-- Integration intake (EP-4): inbox disposition vs the live Keiro.Inbox runtime +-------------------------------------------------------------------------------- + +{- | Emit the inbox node's deterministic disposition wiring compiled against the +LIVE @Keiro.Inbox.Types@: the dedupe policy (a real 'InboxDedupePolicy') and a +disposition function over the real @InboxResult@ (Processed\/Duplicate\/ +InProgress\/PreviouslyFailed). This pins the dangerous inversions +(duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the +runtime types. The handler-level decode\/dedupe\/store failures are noted but not +part of @InboxResult@. Firewall holds (no keiki symbolic operator). +-} +scaffoldIntake :: Context -> IntakeNode -> [ScaffoldModule] +scaffoldIntake ctx i = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs") + , moduleText = emitIntakeGen genPrefix i + , kind = Generated + , origin = nodeOrigin "intake" (inkName i) (inkLoc i) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (inkName i)) + +emitIntakeGen :: Text -> IntakeNode -> Text +emitIntakeGen genPrefix i = + nl + [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" + , generatedBanner + , "module " <> genPrefix <> ".Inbox" + , " ( InboxAck (..)" + , " , inboxDedupePolicy" + , " , inboxPersistence" + , " , inboxDisposition" + , " ) where" + , "" + , "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))" + , "" + , "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy." + , "inboxDedupePolicy :: InboxDedupePolicy" + , "inboxDedupePolicy = " <> inkDedupePolicy i + , "" + , "{- | Success-path envelope retention passed to runInboxTransactionWith." + , "Failures always retain their full operator-facing dead-letter envelope." + , "Dedupe-only success rows decode with an empty payload." + , "-}" + , "inboxPersistence :: InboxPersistence" + , "inboxPersistence = " <> persistenceCtor (inkPersist i) + , "" + , "-- The service's ack decision for each inbox classification." + , "data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter" + , " deriving stock (Eq, Show)" + , "" + , "-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult." + , "-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous" + , "-- inversions the spec states explicitly." + , "inboxDisposition :: InboxResult a -> InboxAck" + , "inboxDisposition r = case r of" + , " InboxProcessed _ -> " <> ackFor "processed" + , " InboxDuplicate -> " <> ackFor "duplicate" + , " InboxInProgress -> " <> ackFor "inProgress" + , " InboxPreviouslyFailed _ -> " <> ackFor "previouslyFailed" + , "" + , "-- handler-level failures (not InboxResult): decodeFailed => " + <> ackText "decodeFailed" + <> ", dedupeFailed => " + <> ackText "dedupeFailed" + <> ", storeFailed => " + <> ackText "storeFailed" + ] + where + act o = lookup o [(drOutcome r, drAction r) | r <- inkDisposition i] + ackFor o = case act o of + Just IAckOk -> "InboxAckOk" + Just (IRetry _) -> "InboxRetry" + Just (IDeadLetter _) -> "InboxDeadLetter" + Nothing -> "InboxRetry" + ackText o = case act o of + Just IAckOk -> "ackOk" + Just (IRetry _) -> "retry" + Just (IDeadLetter _) -> "deadLetter" + Nothing -> "retry" + persistenceCtor InkPersistFull = "PersistFullEnvelope" + persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly" + +-------------------------------------------------------------------------------- +-- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime +-------------------------------------------------------------------------------- + +{- | Emit the publisher's at-least-once policy compiled against the LIVE +@Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff +curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds. +-} +scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule] +scaffoldPublisher ctx pb = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs") + , moduleText = emitPublisherGen genPrefix pb + , kind = Generated + , origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (pubName pb)) + +emitPublisherGen :: Text -> PublisherNode -> Text +emitPublisherGen genPrefix pb = + nl + [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" + , generatedBanner + , "module " <> genPrefix <> ".Publisher" + , " ( publisherOrdering" + , " , publisherBackoff" + , " , publisherMaxAttempts" + , " ) where" + , "" + , "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))" + , "" + , "publisherOrdering :: OrderingPolicy" + , "publisherOrdering = " <> pubOrdering pb + , "" + , "publisherBackoff :: BackoffSchedule" + , "publisherBackoff = " <> backoffExpr (pubBackoff pb) + , "" + , "publisherMaxAttempts :: Int" + , "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb) + ] + where + backoffExpr b = case boKind b of + "constant" -> "ConstantBackoff " <> windowText (boWindow b) + "exponential" -> + "ExponentialBackoff ExponentialBackoffOptions { initial = " + <> windowText (boWindow b) + <> ", maxDelay = " + <> maybe "0" windowText (boMax b) + <> ", multiplier = " + <> fromMaybe "0" (boMultiplier b) + <> " }" + _ -> "error \"keiro-dsl: unlowerable backoff kind\"" + +-------------------------------------------------------------------------------- +-- pgmq workqueue (EP-5): a self-contained Job payload record + codec +-------------------------------------------------------------------------------- + +{- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the +field→wire-name JSON codec, and the captured physical\/dlq\/table name constants. +Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup +predicate are holes (not emitted). Firewall holds. +-} +scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule] +scaffoldWorkqueue ctx w = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs") + , moduleText = emitWorkqueueGen genPrefix w + , kind = Generated + , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + } + , ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs") + , moduleText = emitQueuePolicy genPrefix w + , kind = Generated + , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + } + , ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs") + , moduleText = emitQueueCodec genPrefix w + , kind = Generated + , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (wqName w)) + +emitWorkqueueGen :: Text -> WorkqueueNode -> Text +emitWorkqueueGen genPrefix w = + nl $ + [ "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" + , generatedBanner + , "module " <> genPrefix <> ".Queue" + , " ( " <> payloadTy <> " (..)" + , " , encode" <> payloadTy + , " , parse" <> payloadTy + , " , queuePhysical, queueDlq, queueTable" + , groupKeyExport + , " ) where" + , "" + , "import Data.Aeson (Value, object, withObject, (.:), (.=))" + , "import Data.Aeson.Types (parseEither)" + , "import Data.Text (Text)" + , "import qualified Data.Text as T" + , "" + , "queuePhysical, queueDlq, queueTable :: Text" + , "queuePhysical = " <> tshow (wqPhysical w) + , "queueDlq = " <> tshow (wqDlq w) + , "queueTable = " <> tshow (wqTable w) + , "" + ] + ++ groupKeyLines + ++ [ "data " <> payloadTy <> " = " <> payloadTy + , " { " <> T.intercalate "\n , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w] + , " }" + , " deriving stock (Eq, Show)" + , "" + , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value" + , "encode" <> payloadTy <> " p =" + , " object" + ] + ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)] + ++ [ " ]" + , "" + , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy + , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)" + , " where" + , " go o = " <> payloadTy <> fieldApps (wqPayload w) + , "" + , "mapLeftText :: Either String b -> Either Text b" + , "mapLeftText = either (Left . T.pack) Right" + ] + where + payloadTy = wqPayloadName w + groupKeyExport = case wqGroupKey w of + Nothing -> "" + Just groupKey + | gkVia groupKey == "raw" -> " , groupKeyField, groupKeyFor" + | otherwise -> " , groupKeyField" + groupKeyLines = case wqGroupKey w of + Nothing -> [] + Just groupKey -> common <> derivationLines groupKey + where + common = + [ "groupKeyField :: Text" + , "groupKeyField = " <> tshow (gkField groupKey) + , "" + ] + derivationLines key + | gkVia key == "raw" = + [ "groupKeyFor :: " <> payloadTy <> " -> Text" + , "groupKeyFor payload = payload." <> gkField key + , "" + ] + | otherwise = + [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned." + , "-- Captured fixture: " <> fromMaybe "" (gkFixture key) + , "" + ] + hsType "bool" = "Bool" + hsType "int" = "Int" + hsType _ = "Text" + lead 0 kv = " [ " <> kv + lead _ kv = " , " <> kv + fieldApps [] = "" + fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs] + +{- | Emit the versioned PGMQ envelope adapter. The payload record remains +symbol-free and dependency-light in Queue.hs; this runtime-facing module is +the opt-in assembly point applications import into their Job values. +-} +emitQueueCodec :: Text -> WorkqueueNode -> Text +emitQueueCodec genPrefix w = + nl + [ "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "{- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@." + , "" + , "Deploy workers before producers when raising its schema version. Do not" + , "adopt this codec on a non-empty bare-payload queue without draining it" + , "(or supplying a transitional codec), or in-flight messages will" + , "dead-letter. This is telemetry-neutral:" + , "docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns" + , "spans and acknowledgement vocabulary." + , "-}" + , "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where" + , "" + , "import Data.List.NonEmpty (NonEmpty (..))" + , "import Keiro.Codec (Codec (..), EventType (..))" + , "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)" + , "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")" + , "" + , stem <> "PayloadCodec :: Codec " <> payloadTy + , stem <> "PayloadCodec =" + , " Codec" + , " { eventTypes = EventType " <> tshow payloadTy <> " :| []" + , " , eventType = \\_ -> EventType " <> tshow payloadTy + , " , schemaVersion = 1" + , " , encode = encode" <> payloadTy + , " , decode = \\_ -> parse" <> payloadTy + , " , upcasters = []" + , " }" + , "" + , stem <> "JobCodec :: JobCodec " <> payloadTy + , stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec" + ] + where + payloadTy = wqPayloadName w + stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w)))) + +{- | Emit the pgmq retry policy + JobOutcome disposition compiled against the +LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins +the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient) +and decodeFailure ⇒ Dead (poison). +-} +emitQueuePolicy :: Text -> WorkqueueNode -> Text +emitQueuePolicy genPrefix w = + nl $ + [ "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> genPrefix <> ".QueuePolicy" + , " ( retryPolicy, jobOutcomeFor" + , " , jobOrdering, jobTuningFor, queueProvision" + , " ) where" + , "" + , "import Data.Text (Text)" + , "import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)" + , "" + , "jobOrdering :: JobOrdering" + , "jobOrdering = " <> orderingCtor + , "" + , "-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering." + , "jobTuningFor :: JobTuning -> JobTuning" + , "jobTuningFor = withOrdering jobOrdering" + , "" + , "-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard." + , "queueProvision :: QueueProvision" + , "queueProvision = " <> provisionExpr + , "" + , "retryPolicy :: RetryPolicy" + , "retryPolicy =" + , " RetryPolicy" + , " { maxRetries = " <> tshow' (wqMaxRetries w) + , " , defaultRetryDelay = RetryDelay " <> windowText (wqDelay w) + , " , useDeadLetter = " <> (if wqDlqOn w then "True" else "False") + , " }" + , "" + , "-- The consumer JobOutcome disposition over the spec's named domain outcomes," + , "-- lowered to the live Keiro.PGMQ.Job.JobOutcome." + , "jobOutcomeFor :: Text -> JobOutcome" + , "jobOutcomeFor o = case o of" + ] + ++ [" " <> tshow (wqdOutcome r) <> " -> " <> outcome (wqdAction r) | r <- wqDisposition w] + ++ [" _ -> Retry (RetryDelay " <> windowText (wqDelay w) <> ")"] + where + orderingCtor = case wqOrdering w of + WqUnordered -> "Unordered" + WqFifoThroughput -> "FifoThroughput" + WqFifoRoundRobin -> "FifoRoundRobin" + provisionExpr = fifoWrap baseProvision + fifoWrap expression = case wqOrdering w of + WqUnordered -> expression + _ -> "withFifoIndexProvision (" <> expression <> ")" + baseProvision = case wqProvision w of + WqStandard -> "standardProvision" + WqUnlogged -> "unloggedProvision" + WqPartitioned interval retention -> + "partitionedProvision (PartitionSpec { partitionInterval = " + <> tshow interval + <> ", retentionInterval = " + <> tshow retention + <> " })" + outcome IAckOk = "Done" + outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")" + outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr) + +-------------------------------------------------------------------------------- +-- First-class read models (EP-107) +-------------------------------------------------------------------------------- + +{- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the +qualified-table constant shared by the hand-owned query and the generated +runtime record; @ReadModel@ re-exports it as part of the public surface. +-} +scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule] +scaffoldReadModel ctx readModel = + [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel) + , generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel) + , ScaffoldModule + { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles" + , moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel + , kind = HoleStub + , origin = readModelOrigin + } + ] + where + nodeSegment = pascal (rmName readModel) + stem = readModelStem readModel + readModelModule = genPrefixFor ctx nodeSegment + tableModule = readModelModule <> ".ReadModelTable" + readModelHolePrefix = holePrefixFor ctx nodeSegment + readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel) + generated leaf body = + ScaffoldModule + { modulePath = modulePathFor readModelModule leaf + , moduleText = body + , kind = Generated + , origin = readModelOrigin + } + +modulePathFor :: Text -> Text -> FilePath +modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs") + +readModelStem :: ReadModelNode -> Text +readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName + +emitReadModelTable :: Text -> Text -> ReadModelNode -> Text +emitReadModelTable tableModule stem readModel = + nl + [ "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> tableModule <> " (" <> qualifiedName <> ") where" + , "" + , "import Data.Text (Text)" + , "import Keiro.Connection (qualifyTable)" + , "" + , "-- The fully-qualified, double-quoted data-table reference." + , qualifiedName <> " :: Text" + , qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel) + ] + where + qualifiedName = stem <> "QualifiedTable" + +emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text +emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel = + nl $ + [ "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> readModelModule <> ".ReadModel" + , " ( " <> T.intercalate "\n , " exports + , " ) where" + , "" + , "import Data.Functor (void)" + , "import Effectful (Eff, (:>))" + , "import " <> tableModule <> " (" <> qualifiedName <> ")" + , "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")" + ] + ++ asyncImports + ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)" + , "import Keiro.ReadModel.Rebuild qualified as Rebuild" + , "import Kiroku.Store.Effect (Store)" + , "import Kiroku.Store.Types (" <> kirokuTypes <> ")" + , "" + , readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType + , readModelName <> " =" + , " ReadModel" + , " { name = " <> tshow registryName + , " , tableName = " <> tshow (rmTable readModel) + , " , schema = " <> tshow (rmSchema readModel) + , " , subscriptionName = " <> tshow subscriptionName + , " , version = " <> tshow' (rmVersion readModel) + , " , shapeHash = " <> tshow (rmShape readModel) + , " , defaultConsistency = " <> consistencyExpr (rmConsistency readModel) + , " , strongScope = " <> scopeExpr (rmScope readModel) + , " , query = " <> queryName + , " }" + , "" + , "-- Call once at projection startup before serving queries." + , registerName <> " :: (Store :> es) => Eff es ()" + , registerName <> " =" + , " void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")" + , "" + , startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata" + , startName <> " =" + , " Rebuild.startRebuild " <> readModelName <> " " <> projectionNames + , "" + , finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)" + , finishName <> " =" + , " Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames + , "" + , abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata" + , abandonName <> " = Rebuild.abandonRebuild " <> readModelName + ] + ++ asyncDefinition + where + registryName = registryNameFor (contextName ctx) readModel + subscriptionName = subscriptionNameFor (contextName ctx) readModel + asyncName = registryName <> "-async" + readModelName = stem <> "ReadModel" + qualifiedName = stem <> "QualifiedTable" + registerName = "register" <> pascal stem + startName = "start" <> pascal stem <> "Rebuild" + finishName = "finish" <> pascal stem <> "Rebuild" + abandonName = "abandon" <> pascal stem <> "Rebuild" + asyncValueName = stem <> "AsyncProjection" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = + [ readModelName + , qualifiedName + , registerName + , startName + , finishName + , abandonName + ] + ++ [asyncValueName | rmFeed readModel == RmSubscription] + holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + asyncImports = case rmFeed readModel of + RmInline -> [] + RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"] + kirokuTypes = case rmFeed readModel of + RmInline -> "GlobalPosition" + RmSubscription -> "GlobalPosition, RecordedEvent (..)" + projectionNames = case rmFeed readModel of + RmInline -> "[]" + RmSubscription -> "[" <> tshow asyncName <> "]" + asyncDefinition = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "" + , asyncValueName <> " :: AsyncProjection" + , asyncValueName <> " =" + , " AsyncProjection" + , " { name = " <> tshow asyncName + , " , readModelName = " <> tshow registryName + , " , subscriptionName = " <> tshow subscriptionName + , " , applyRecorded = " <> applyName + , " , idempotencyKey = \\recorded -> recorded.eventId" + , " }" + ] + consistencyExpr Strong = "Strong" + consistencyExpr Eventual = "Eventual" + scopeExpr Nothing = "EntireLog" + scopeExpr (Just RmEntireLog) = "EntireLog" + scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName + +emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text +emitReadModelHoles tableModule readModelHolePrefix stem readModel = + nl $ + [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it." + , "module " <> readModelHolePrefix <> ".ReadModelHoles" + , " ( " <> T.intercalate "\n , " exports + , " ) where" + , "" + , "import " <> tableModule <> " (" <> qualifiedName <> ")" + , "import Hasql.Transaction qualified as Tx" + ] + ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription] + ++ [ "" + , "-- HOLE: replace these aliases with the real query input and result types." + , "type " <> queryInputType <> " = ()" + , "type " <> queryResultType <> " = ()" + , "" + , "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path." + , "-- Declared columns:" + ] + ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) + ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType + , queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query") + ] + ++ applyStub + where + qualifiedName = stem <> "QualifiedTable" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + applyStub = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "" + , "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe." + , applyName <> " :: RecordedEvent -> Tx.Transaction ()" + , applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply") + ] + +qualifiedTableLiteral :: ReadModelNode -> Text +qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel) + +quoteSqlIdentifier :: Text -> Text +quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\"" + +readModelColumnDoc :: RmColumn -> Text +readModelColumnDoc columnDecl = + rmcName columnDecl + <> " " + <> rmcType columnDecl + <> if rmcRequired columnDecl then " NOT NULL" else "" + +-------------------------------------------------------------------------------- +-- Router + shared worker-policy lowering (EP-108) +-------------------------------------------------------------------------------- + +scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule] +scaffoldRouter ctx router = + [ ScaffoldModule + { modulePath = modulePathFor genPrefix "Router" + , moduleText = emitRouterGen genPrefix router + , kind = Generated + , origin = routerOrigin + } + , ScaffoldModule + { modulePath = modulePathFor holePrefix "RouterHoles" + , moduleText = emitRouterHoles holePrefix router + , kind = HoleStub + , origin = routerOrigin + } + ] + where + genPrefix = genPrefixFor ctx (rtId router) + holePrefix = holePrefixFor ctx (rtId router) + routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router) + +emitRouterGen :: Text -> RouterNode -> Text +emitRouterGen genPrefix router = + nl $ + [ "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> genPrefix <> ".Router" + , " ( " <> stem <> "Name" + , " , " <> stem <> "WorkerOptions" + , " ) where" + , "" + , "import Data.Text (Text)" + ] + ++ workerPolicyImports (rtPoison router) + ++ [ "" + , "-- The STABLE router name. It participates in every target-keyed" + , "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches." + , stem <> "Name :: Text" + , stem <> "Name = " <> tshow (rtName router) + , "" + , "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId," + , "-- targetStreamName, occurrence). Target-keyed, not positional." + , "" + , "-- Node-level worker policy lowered from the spec. Pass this value to" + , "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions." + ] + ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router) + where + stem = lowerFirst (rtId router) + +emitRouterHoles :: Text -> RouterNode -> Text +emitRouterHoles holePrefix router = + nl + [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies." + , "-- keiro-dsl creates it once and never overwrites it." + , "module " <> holePrefix <> ".RouterHoles () where" + , "" + , "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]" + , "-- Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> "." + , "-- The spec's 'stable' keyword acknowledges that retry attempts accumulate" + , "-- the UNION of resolved target identities. Keep the recipient set stable" + , "-- for a source event whenever an exact recipient set matters." + , "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name," + , "-- key, resolve, targetEventStream, and targetProjections; run it with" + , "-- runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions." + , "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> "." + , "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate" + , "-- event id against the TARGET stream via confirmBenignDuplicate before" + , "-- returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise." + ] + where + renderNames names = "[" <> T.intercalate ", " names <> "]" + +resolveSourceText :: ResolveSource -> Text +resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)" +resolveSourceText ResolveHole = "typed resolver hole" + +workerPolicyImports :: PolicyChoice -> [Text] +workerPolicyImports poison = + [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))" + , "import Shibuya.Core.Ack (RetryDelay (..))" + ] + ++ if poison == PolHalt + then [] + else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"] + +workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text] +workerOptionsLines valueName rejected poison = + [ valueName <> signature + , valueName <> argument <> " =" + , " WorkerOptions" + , " { poisonPolicy = " <> poisonExpr + , " , rejectedCommandPolicy = " <> rejectedExpr rejected + , " , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning" + , " , metrics = Nothing -- runtime configuration; install at call site" + , " }" + ] + where + signature = case poison of + PolHalt -> " :: WorkerOptions es msg" + _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg" + argument = case poison of + PolHalt -> "" + _ -> " poisonCallback" + poisonExpr = case poison of + PolHalt -> "PoisonHalt" + PolDeadLetter -> "PoisonDeadLetter poisonCallback" + PolSkip -> "PoisonSkip poisonCallback" + rejectedExpr = \case + PolHalt -> "RejectedHalt" + PolDeadLetter -> "RejectedDeadLetter" + PolSkip -> "RejectedSkip" + +-------------------------------------------------------------------------------- +-- Process manager + durable timer (EP-3) +-------------------------------------------------------------------------------- + +{- | Emit the symbol-free deterministic wiring for a process manager + its timer +into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the +behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the +fire command). The @Generated@ module contains no keiki symbolic operator (the +saga's transducer is the separate aggregate hole), so the firewall invariant +holds. The timer worker uses the spec's @max-attempts@ ceiling, never the +dangerous @defaultTimerWorkerOptions@ (@Nothing@) default. +-} +scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule] +scaffoldProcess ctx p = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs") + , moduleText = emitProcessGen ctxPascal genPrefix holePrefix p + , kind = Generated + , origin = nodeOrigin "process" (procId p) (procLoc p) + } + , ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs") + , moduleText = emitProcessHoles genPrefix holePrefix p + , kind = HoleStub + , origin = nodeOrigin "process" (procId p) (procLoc p) + } + ] + where + ctxPascal = pascalFromKebab (contextName ctx) + genPrefix = genPrefixFor ctx (procId p) + holePrefix = holePrefixFor ctx (procId p) + +emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text +emitProcessGen _ctxPascal genPrefix _holePrefix p = + nl $ + [ "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> genPrefix <> ".Process" + , " ( " <> lo <> "ProcessName" + , " , " <> lo <> "Category" + , " , " <> lo <> "ProcessWorkerOptions" + , " , " <> lo <> "TimerRequest" + , " , " <> lo <> "FireOutcome" + , " ) where" + , "" + , "import Data.Aeson (Value, object, (.=))" + , "import Data.Text (Text)" + , "import qualified Data.Text as T" + , "import Data.Time (UTCTime)" + , "import Data.UUID (UUID)" + , "import qualified Data.UUID.V5 as UUID.V5" + , "import Keiro.Command (CommandError (..))" + , "import Keiro.Stream qualified as Stream" + , "import Keiro.Timer (TimerId (..), TimerRequest (..))" + ] + ++ workerPolicyImports (procPoison p) + ++ [ "" + , "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped)." + , lo <> "ProcessName :: Text" + , lo <> "ProcessName = " <> tshow (procName p) + , "" + , "-- The validated saga stream category (hole-kind 5: referenced, never retyped)." + , "-- Saga streams are '-' via Keiro.Stream.entityStream." + , "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal." + , lo <> "Category :: Stream.StreamCategory a" + , lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName + , "" + , "-- Node-level worker policy lowered from the spec. Pass this value to" + , "-- Keiro.ProcessManager.runProcessManagerWorkerWith." + ] + ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p) + ++ [ "" + , "-- The deterministic timer-request builder: id derived from the correlation" + , "-- key (hole-kind 1), processManagerName referenced, payload from the spec." + , "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)" + , lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest" + , lo <> "TimerRequest correlationId fireAtTime =" + , " TimerRequest" + , " { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))" + , " , processManagerName = " <> lo <> "ProcessName" + , " , correlationId = correlationId" + , " , fireAt = fireAtTime" + , " , payload = " <> payloadExpr (tmPayload timer) + , " }" + , "" + , "-- The timer-fire disposition table (hole-kind 2), derived from the spec." + , "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion." + , "-- A duplicate append reaches on-error unless it is confirmed against the" + , "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:" + , "-- StreamName -> EventId -> CommandError -> Eff es Bool" + , "-- Fold True into the duplicate result and surface False as the failure." + , lo <> "FireOutcome :: Either CommandError a -> Maybe ()" + , lo <> "FireOutcome result = case result of" + , " Right{} -> " <> outcomeToMaybe (onOk fd) + , " Left CommandRejected -> " <> outcomeToMaybe (onReject fd) + , " Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> " -- explicit definition-bug arm" + , " Left{} -> " <> outcomeToMaybe (onError fd) + , "" + , "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer) + , "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the" + , "-- defaultTimerWorkerOptions Nothing ceiling that retries forever)." + , "" + , "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1)." + , "namedUuid :: Text -> UUID" + , "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))" + ] + where + lo = lowerFirst (procId p) + categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p)) + timer = procTimer p + fd = fireDisposition (tmFire timer) + +{- | The timer payload, restricted to the spec's literal (@name=\"value\"@) +bindings so it compiles in the deterministic builder. Bare fields and +ref-valued bindings are input-driven (the agent-written hole), not emitted. +-} +payloadExpr :: [FieldBinding] -> Text +payloadExpr fs = case [b | b <- fs, isLiteral b] of + [] -> "object []" + lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]" + where + isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes) + kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)" + stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\"" + +showOutcome :: FireOutcome -> Text +showOutcome OFired = "Fired" +showOutcome ORetry = "Retry" + +outcomeToMaybe :: FireOutcome -> Text +outcomeToMaybe OFired = "Just () -- Fired" +outcomeToMaybe ORetry = "Nothing -- Retry" + +emitProcessHoles :: Text -> Text -> ProcessNode -> Text +emitProcessHoles _genPrefix holePrefix p = + nl + [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies." + , "-- keiro-dsl creates it once and never overwrites it." + , "module " <> holePrefix <> ".ProcessHoles () where" + , "" + , "-- HOLE handle: build the ProcessManagerAction (the self-advance" + , "-- '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input." + , "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;" + , "-- build target streams with entityStream " <> lowerFirst (procTarget p) <> "Category. Never concatenate raw stream names." + , "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;" + , "-- surgeDeadline observedAt = addUTCTime surgeWindow observedAt (TIME INJECTED)." + , "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire," + , "-- keyed by correlationId; the fired-event-id is the deterministic uuidv5 of" + , "-- " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId." + , "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate" + , "-- event id against the TARGET stream via confirmBenignDuplicate before" + , "-- returning PMCommandDuplicate. Its effective signature is:" + , "-- StreamName -> EventId -> CommandError -> Eff es Bool" + , "-- Hand-rolled paths must call it with the target stream and attempted event id," + , "-- fold True into the duplicate result, and surface False as the original failure." + , "-- Never pattern-match DuplicateEvent as success: event ids are globally unique." + ] + +-------------------------------------------------------------------------------- +-- Domain module +-------------------------------------------------------------------------------- + +emitDomain :: Agg -> Text +emitDomain a = + nl $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DuplicateRecordFields #-}" + ] + ++ ["{-# LANGUAGE DeriveAnyClass #-}" | hasSnapshot a] + ++ [ "{-# LANGUAGE OverloadedStrings #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}" + , generatedBanner + , "module " <> aGenPrefix a <> ".Domain where" + , "" + ] + ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a] + ++ [ "import Data.Proxy (Proxy (..))" + , "import Data.Text (Text)" + , "import GHC.Generics (Generic)" + , "import Keiki.Core (RegFile (..))" + ] + ++ ["import Keiki.Shape (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a] + ++ map ("import " <>) (domainConsumerImports a) + ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)" + , "" + , sectionsOf + [ map (emitId a) (aIds a) + , map (emitEnum a) (aEnums a) + , [emitVertex a] + , map (emitRecord a) (aCommands a) + , [emitSum (aName a <> "Command") (aCommands a)] + , map (emitRecord a) (aEvents a) + , [emitSum (aName a <> "Event") (aEvents a)] + , [emitRegsType a, emitInitialRegs a] + , + [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)" + , "" + , "$(deriveWireCtorsAll ''" <> aName a <> "Event)" + ] + ] + ] + +hasSnapshot :: Agg -> Bool +hasSnapshot = maybe False (const True) . aSnapshot + +emitId :: Agg -> IdDecl -> Text +emitId a d = + nl $ + [ "newtype " <> idName d <> " = " <> idName d <> " Text" + , " deriving stock (Generic, Eq, Ord, Show)" + ] + ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] + ++ ["instance CanonicalTypeName " <> idName d | hasSnapshot a] + ++ [ "" + , lowerFirst (idName d) <> "Text :: " <> idName d <> " -> Text" + , lowerFirst (idName d) <> "Text (" <> idName d <> " t) = t" + ] + +emitEnum :: Agg -> EnumDecl -> Text +emitEnum a d = + nl $ + [ "data " <> enumName d <> " = " <> T.intercalate " | " (map fst (enumCtors d)) + , " deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)" + ] + ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] + ++ ["instance CanonicalTypeName " <> enumName d | hasSnapshot a] + ++ [ "" + , lowerFirst (enumName d) <> "Text :: " <> enumName d <> " -> Text" + , lowerFirst (enumName d) <> "Text = \\case" + , nl [" " <> c <> " -> " <> tshow w | (c, w) <- enumCtors d] + ] + +emitVertex :: Agg -> Text +emitVertex a = + nl $ + [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a)) + , " deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)" + ] + ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] + ++ [ line + | hasSnapshot a + , line <- + [ "instance CanonicalStateShape " <> aVertexType a + , "instance CanonicalTypeName " <> aVertexType a + ] + ] + +emitRecord :: Agg -> ResolvedCtor -> Text +emitRecord a rc = + nl $ + [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data" + ] + ++ recordFields [(name, renderDomainType a fieldType) | (name, fieldType) <- rcFields rc] + ++ [" deriving stock (Generic, Eq, Show)"] + +recordFields :: [(Text, Text)] -> [Text] +recordFields [] = + [" {"] + <> [" }"] +recordFields fs = + [ lead i <> n <> " :: !" <> ty + | (i, (n, ty)) <- zip [(0 :: Int) ..] fs + ] + ++ [" }"] + where + lead 0 = " { " + lead _ = " , " + +emitSum :: Text -> [ResolvedCtor] -> Text +emitSum tyName ctors = + nl $ + [firstLine] ++ restLines ++ [" deriving stock (Generic, Eq, Show)"] + where + arm rc = rc' rc + rc' rc = rcName rc <> " !" <> rcName rc <> "Data" + (firstLine, restLines) = case ctors of + [] -> ("data " <> tyName <> " = ()", []) + (c : cs) -> + ( "data " <> tyName <> " = " <> arm c + , [" | " <> arm c2 | c2 <- cs] + ) + +emitRegsType :: Agg -> Text +emitRegsType a = + nl $ + ["type " <> aName a <> "Regs ="] + ++ regListLines a (aRegs a) + +regListLines :: Agg -> [RegDecl] -> [Text] +regListLines _ [] = [" '[]"] +regListLines a rs = + [ lead i <> "'(" <> tshow (regName r) <> ", " <> renderDomainType a (regType r) <> ")" + | (i, r) <- zip [(0 :: Int) ..] rs + ] + ++ [" ]"] + where + lead 0 = " '[ " + lead _ = " , " + +emitInitialRegs :: Agg -> Text +emitInitialRegs a = + nl $ + [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs" + , "initial" <> aName a <> "Regs =" + ] + ++ chain (aRegs a) + where + chain [] = [" RNil"] + chain rs = + [ " RCons (Proxy @" <> tshow (regName r) <> ") " <> regInitialValue a r <> " $" + | r <- init rs + ] + ++ [" RCons (Proxy @" <> tshow (regName lastR) <> ") " <> regInitialValue a lastR <> " RNil"] + where + lastR = last rs + +-- | The Haskell initial value for a register, by the category of its type. +regInitialValue :: Agg -> RegDecl -> Text +regInitialValue a r + | Just declaration <- mappedDeclFor a (regType r) = case mappedInitial declaration of + Just initialValue -> unQualifiedValueName initialValue + Nothing -> "(error \"mapped register initial rejected before generation\")" + | regType r `elem` idNames = "(" <> regType r <> " \"\")" + | regType r == aVertexType a = maybe "(error \"invalid vertex initial\")" (vertexCtor a) (bareInitial r) + | regType r == "Text" = maybe "(error \"Text initial must be quoted\")" tshow (textInitial r) + | otherwise = maybe "(error \"invalid register initial\")" id (bareInitial r) + where + idNames = map idName (aIds a) + bareInitial reg = case regInitial reg of + RegInitBare value -> Just value + RegInitText _ -> Nothing + textInitial reg = case regInitial reg of + RegInitText value -> Just value + RegInitBare _ -> Nothing + +domainConsumerImports :: Agg -> [Text] +domainConsumerImports a = + sort . nub $ + [ hsModule (mappedHaskell declaration) <> " qualified" + | declaration <- mappedUses a + ] + <> [ qualifiedModule initialValue <> " qualified" + | declaration <- mappedUses a + , initialValue <- maybeToListText (mappedInitial declaration) + ] + +mappedUses :: Agg -> [ResolvedMappedDecl] +mappedUses a = + [ declaration + | fieldType <- + map snd (concatMap rcFields (aCommands a <> aEvents a)) + <> map regType (aRegs a) + , declaration <- maybeToListText (mappedDeclFor a fieldType) + ] + +mappedDeclFor :: Agg -> Text -> Maybe ResolvedMappedDecl +mappedDeclFor a name = do + graph <- aTypeGraph a + Map.lookup (MappedKey name) (tgDeclarations graph) + +mappedHaskell :: ResolvedMappedDecl -> HaskellSource +mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration +mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration + +mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName +mappedInitial (ResolvedStructural declaration _) = sdInitial declaration +mappedInitial (ResolvedOpaque declaration) = odInitial declaration + +renderDomainType :: Agg -> Text -> Text +renderDomainType a fieldType = + maybe fieldType (renderHaskellSource . mappedHaskell) (mappedDeclFor a fieldType) + +maybeToListText :: Maybe value -> [value] +maybeToListText = maybe [] pure + +-------------------------------------------------------------------------------- +-- Codec module +-------------------------------------------------------------------------------- + +emitCodec :: Agg -> Text +emitCodec a = + nl $ + [ "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> aGenPrefix a <> ".Codec (" + , " " <> lowerFirst (aName a) <> "Codec," + , " parse" <> aName a <> "Event," + , " encode" <> aName a <> "Event," + ] + ++ concatMap mappedExports (codecMappedDeclarations a) + ++ [ ") where" + , "" + , "import " <> aGenPrefix a <> ".Domain" + ] + ++ ( if hasMappedCodec a + then + [ "import Control.Monad (unless)" + , "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))" + , "import Data.Aeson.Key qualified as Key" + , "import Data.Aeson.KeyMap qualified as KeyMap" + ] + else ["import Data.Aeson (Value, object, withObject, (.:), (.=))"] + ) + ++ [ "import Data.Aeson.Types (Parser, parseEither)" + , "import Data.List.NonEmpty (NonEmpty (..))" + ] + ++ ( if hasMappedCodec a + then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"] + else [] + ) + ++ [ "import Data.Text (Text)" + , "import qualified Data.Text as T" + ] + ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasMappedCodec a] + ++ [ "import Keiro.Codec (Codec (..), EventType (..))" + , upcasterImport a + ] + ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a] + ++ [ "" + , emitEnumParsers a + ] + ++ [emitMappedCodecs a | hasMappedCodec a] + ++ [ "" + , emitCodecValue a + , "" + , emitEncode a + , "" + , emitDecode a + , "" + , "mapLeftText :: Either String b -> Either Text b" + , "mapLeftText = either (Left . T.pack) Right" + ] + ++ ( if hasMappedCodec a + then + [ "" + , "rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()" + , "rejectUnknownFields label allowed objectValue =" + , " unless (null extras) (fail (label <> \" contains unknown fields: \" <> show extras))" + , " where" + , " extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))" + ] + else [] + ) + where + mappedExports (ResolvedStructural declaration _) = + [ " encode" <> sdName declaration <> "Mapped," + , " decode" <> sdName declaration <> "Mapped," + ] + mappedExports ResolvedOpaque{} = [] + +hasMappedCodec :: Agg -> Bool +hasMappedCodec = not . null . codecMappedDeclarations + +emitEnumParsers :: Agg -> Text +emitEnumParsers a = sectionsOf [[emitEnumParser e | e <- aEnums a]] + +emitEnumParser :: EnumDecl -> Text +emitEnumParser d = + nl $ + [ "parse" <> enumName d <> " :: Text -> Parser " <> enumName d + , "parse" <> enumName d <> " = \\case" + ] + ++ [" " <> tshow w <> " -> pure " <> c | (c, w) <- enumCtors d] + ++ [" _ -> fail " <> tshow ("unknown " <> enumName d)] + +emitCodecValue :: Agg -> Text +emitCodecValue a = + nl $ + [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event" + , lowerFirst (aName a) <> "Codec =" + , " Codec" + , " { eventTypes = " <> eventTypesExpr + , " , eventType = \\case" + ] + ++ [" " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a] + ++ [ " , schemaVersion = " <> tshow' (maxEventVersion a) + , " , encode = encode" <> aName a <> "Event" + , " , decode = parse" <> aName a <> "Event" + , " , upcasters = " <> upcastersExpr a + , " }" + ] + ++ upcasterRungDecls a + where + eventTypesExpr = case map rcName (aEvents a) of + [] -> "error \"no events\"" + (e : es) -> "EventType " <> tshow e <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) es) <> "]" + +-- | The codec's @schemaVersion@: the maximum declared event version (EP-2). +maxEventVersion :: Agg -> Int +maxEventVersion a = maximum (1 : map rcVersion (aEvents a)) + +{- | One @(sourceVersion, upcasterName)@ entry per event that declares an +@upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its +body is a hole in the hand-owned Holes module. +-} +upcasterEntries :: Agg -> [(Int, Text, Text)] +upcasterEntries a = + [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m) + | e <- aEvents a + , Just m <- [rcUpcastFrom e] + ] + +upcastersExpr :: Agg -> Text +upcastersExpr a = + "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]" + +{- | Group event-specific holes into one migration rung per aggregate-global +source version. Event metadata stamps every kind with the aggregate's +schema version, so a rung must explicitly pass foreign event kinds through. +-} +upcasterRungs :: Agg -> [(Int, [(Text, Text)])] +upcasterRungs a = + [ (source, [(eventName, fn) | (_, eventName, fn) <- entries]) + | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a)) + ] + where + firstSource (source, _, _) = source + sameSource (source, _, _) (otherSource, _, _) = source == otherSource + +upcasterRungDecls :: Agg -> [Text] +upcasterRungDecls a = concatMap rung (upcasterRungs a) + where + rung (source, entries) = + [ "" + , "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value" + ] + ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value" + | (eventName, fn) <- entries + ] + ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their" + , "-- stamped version is aggregate-global, not their own shape history." + , "upcastRungV" <> tshow' source <> " _ value = Right value" + ] + +{- | When the codec references upcasters, it imports their (hole) definitions +from the hand-owned Holes module. +-} +upcasterImport :: Agg -> Text +upcasterImport a = case upcasterEntries a of + [] -> "" + es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " [fn | (_, _, fn) <- es] <> ")" + +emitEncode :: Agg -> Text +emitEncode a = + nl $ + [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value" + , "encode" <> aName a <> "Event = \\case" + ] + ++ concatMap encodeArm (aEvents a) + where + encodeArm e = + [ " " <> rcName e <> " payload ->" + , " object" + ] + ++ [ lead i <> kv + | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e)) + ] + ++ [" ]"] + lead 0 = " [ " + lead _ = " , " + encodeField (n, ty) = + tshow n + <> " .= " + <> case fieldCat a ty of + IdCat -> lowerFirst ty <> "Text payload." <> n + EnumCat -> lowerFirst ty <> "Text payload." <> n + MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> n + MappedOpaqueCat{} -> "toJSON payload." <> n + _ -> "payload." <> n + +emitDecode :: Agg -> Text +emitDecode a = + nl $ + [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event" + , "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)" + , " where" + , " go o = do" + , " case tag of" + ] + ++ concatMap decodeArm (aEvents a) + ++ [" _ -> fail \"unknown event type\""] + where + decodeArm e = + [ " " <> tshow (rcName e) <> " ->" + , " " <> rcName e <> " <$> (" <> rcName e <> "Data" <> fieldApps (rcFields e) <> ")" + ] + fieldApps [] = "" + fieldApps fs = " <$> " <> T.intercalate " <*> " (map decodeField fs) + -- The first field uses <$> (handled above), the rest <*>. We instead build + -- a uniform list and join; for an empty record there are no fields. + decodeField (n, ty) = case fieldCat a ty of + IdCat -> "(" <> ty <> " <$> o .: " <> tshow n <> ")" + EnumCat -> "(o .: " <> tshow n <> " >>= parse" <> ty <> ")" + MappedStructuralCat declaration _ -> "(o .: " <> tshow n <> " >>= parse" <> sdName declaration <> "Mapped)" + MappedOpaqueCat{} -> "o .: " <> tshow n + _ -> "o .: " <> tshow n + +codecMappedImports :: Agg -> [Text] +codecMappedImports a = case aTypeGraph a of + Nothing -> [] + Just graph -> + sort . nub $ + [ structuralShapeModule (aContext a) (sdName declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ hsModule (sdHaskell declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ qualifiedModule (sdBinding declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ hsModule (odHaskell declaration) <> " qualified" + | ResolvedOpaque declaration <- codecMappedDeclarations a + ] + <> [ hsModule (odHaskell declaration) <> " qualified" + | ResolvedStructural _ shape <- codecMappedDeclarations a + , key <- directShapeRefs shape + , Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)] + ] + +codecMappedDeclarations :: Agg -> [ResolvedMappedDecl] +codecMappedDeclarations a = case aTypeGraph a of + Nothing -> [] + Just graph -> + mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected)) + where + roots = + [ MappedKey fieldType + | event <- aEvents a + , (_, fieldType) <- rcFields event + , Map.member (MappedKey fieldType) (tgDeclarations graph) + ] + selected = + Map.fromList + [ (key, ()) + | root <- roots + , key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph)) + ] + +directShapeRefs :: ResolvedMappedShape -> [MappedKey] +directShapeRefs = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields + , onEnum = const [] + , onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms + } + +exprRefs :: ResolvedTypeExpr -> [MappedKey] +exprRefs = + foldTypeExpr + TypeExprAlgebra + { onText = [] + , onInt = [] + , onBool = [] + , onNatural = [] + , onTime = [] + , onJson = [] + , onOptional = id + , onList = id + , onMap = id + , onRef = pure + } + +emitMappedCodecs :: Agg -> Text +emitMappedCodecs a = case aTypeGraph a of + Nothing -> "" + Just graph -> + T.intercalate + "\n\n" + [ emitStructuralCodec a graph declaration shape + | ResolvedStructural declaration shape <- codecMappedDeclarations a + ] + +emitStructuralCodec :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitStructuralCodec a graph declaration shape = + nl + [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value" + , "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding + , "" + , "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType + , "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value" + , "" + , "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType + , "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped" + , "" + , "encode" <> name <> "Shape :: " <> shapeType <> " -> Value" + , emitShapeEncoder a graph declaration shape + , "" + , "parse" <> name <> "Shape :: Value -> Parser " <> shapeType + , emitShapeDecoder a graph declaration shape + ] + where + name = sdName declaration + consumerType = renderHaskellSource (sdHaskell declaration) + shapeType = structuralShapeModule (aContext a) name <> "." <> name <> "Shape" + binding = unQualifiedValueName (sdBinding declaration) + +emitShapeEncoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeEncoder a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + nl $ + ["encode" <> name <> "Shape shape =", " object"] + <> objectEntries + [ tshow (rwfKey field) + <> " .= " + <> encodeShapeExpr a graph (rwfType field) (shapeModuleName <> "." <> rwfHaskell field <> " shape") + | field <- fields + ] + , onEnum = \entries -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> [" " <> shapeModuleName <> "." <> weCtor entry <> " -> String " <> tshow (weTag entry) | entry <- entries] + , onUnion = \encoding arms -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> concatMap (unionEncodeArm encoding) arms + } + where + name = sdName declaration + shapeModuleName = structuralShapeModule (aContext a) name + unionEncodeArm encoding arm = + [ " " <> shapeModuleName <> "." <> rwaCtor arm <> payloadPattern <> " ->" + , " object" + ] + <> objectEntries + ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"] + <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload" + | payload <- maybeToListText (rwaPayload arm) + ] + ) + where + payloadPattern = maybe "" (const " payload") (rwaPayload arm) + +emitShapeDecoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeDecoder a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor unknownFields fields -> + nl $ + [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do" + ] + <> rejectLine " " unknownFields (map rwfKey fields) "objectValue" + <> [ " " <> shapeModuleName <> "." <> constructor + , " <$> " <> T.intercalate "\n <*> " (map (decodeRecordField a graph) fields) + ] + , onEnum = \entries -> + nl $ + [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of" + ] + <> [" " <> tshow (weTag entry) <> " -> pure " <> shapeModuleName <> "." <> weCtor entry | entry <- entries] + <> [" _ -> fail " <> tshow ("unknown " <> name <> " wire value")] + , onUnion = \encoding arms -> + nl $ + [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do" + , " tag <- objectValue .: " <> tshow (ueTagField encoding) <> " :: Parser Text" + , " case tag of" + ] + <> concatMap (unionDecodeArm encoding) arms + <> [" _ -> fail " <> tshow ("unknown " <> name <> " union tag")] + } + where + name = sdName declaration + shapeModuleName = structuralShapeModule (aContext a) name + rejectLine _ IgnoreUnknown _ _ = [] + rejectLine indent RejectUnknown allowed objectName = + [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName] + unionDecodeArm encoding arm = + [" " <> tshow (rwaTag arm) <> " -> do"] + <> rejectLine " " (ueUnknownFields encoding) allowed "objectValue" + <> [ case rwaPayload arm of + Nothing -> " pure " <> shapeModuleName <> "." <> rwaCtor arm + Just payload -> + " " + <> shapeModuleName + <> "." + <> rwaCtor arm + <> " <$> (objectValue .: " + <> tshow (ueContentsField encoding) + <> " >>= (" + <> decodeShapeExpr a graph payload + <> "))" + ] + where + allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing] + +decodeRecordField :: Agg -> TypeGraph -> ResolvedWireField -> Text +decodeRecordField a graph field = case rwfPresence field of + PRequired -> + "((objectValue .: " <> key <> " :: Parser Value) >>= (" <> decoder <> "))" + POptional -> + "(case KeyMap.lookup (Key.fromText " + <> key + <> ") objectValue of Nothing -> " + <> missing + <> "; Just presentValue -> " + <> "(" + <> decoder + <> ") presentValue)" + where + key = tshow (rwfKey field) + decoder = decodeShapeExpr a graph (rwfType field) + missing = case rwfOnMissing field of + Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field) + Just onMissing -> "pure " <> renderMissingDefault a graph (rwfType field) onMissing + +encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text +encodeShapeExpr _a graph expression value = + foldTypeExpr + TypeExprAlgebra + { onText = \v -> "toJSON (" <> v <> ")" + , onInt = \v -> "toJSON (" <> v <> ")" + , onBool = \v -> "toJSON (" <> v <> ")" + , onNatural = \v -> "toJSON (" <> v <> ")" + , onTime = \v -> "toJSON (" <> v <> ")" + , onJson = id + , onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")" + , onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))" + , onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))" + , onRef = \key v -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")" + Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")" + Nothing -> "toJSON (" <> v <> ")" + } + expression + value + +decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text +decodeShapeExpr _a graph = + foldTypeExpr + TypeExprAlgebra + { onText = "parseJSON" + , onInt = "parseJSON" + , onBool = "parseJSON" + , onNatural = "parseJSON" + , onTime = "parseJSON" + , onJson = "pure" + , onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other" + , onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")" + , onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")" + , onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape" + Just (ResolvedOpaque _) -> "parseJSON" + Nothing -> "parseJSON" + } + +renderMissingDefault :: Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text +renderMissingDefault a graph expression = \case + OmNull -> "Nothing" + OmText value -> tshow value + OmInt value -> T.pack (show value) + OmBool value -> if value then "True" else "False" + OmEmptyList -> "[]" + OmEmptyMap -> "Map.empty" + OmCtor constructor -> case expression of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> structuralShapeModule (aContext a) (sdName declaration) <> "." <> constructor + _ -> constructor + _ -> constructor + +objectEntries :: [Text] -> [Text] +objectEntries entries = + [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries] + <> [" ]"] + where + lead 0 = " [ " + lead _ = " , " + +renderTextList :: [Text] -> Text +renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" + +-------------------------------------------------------------------------------- +-- EventStream module +-------------------------------------------------------------------------------- + +emitEventStream :: Agg -> Text +emitEventStream a = + nl $ + [ generatedBanner + , "module " <> aGenPrefix a <> ".EventStream" + , " ( " <> lowerFirst (aName a) <> "Category" + , " , " <> lowerFirst (aName a) <> "EventStream" + , " , " <> lowerFirst (aName a) <> "EventStreamDef" + , " , " <> aName a <> "EventStream" + , " , " <> aName a <> "EventStreamDef" + ] + ++ [" , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a] + ++ [ " ) where" + , "" + , "import " <> aGenPrefix a <> ".Domain" + , "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)" + , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst (aName a) <> "Transducer)" + , "import Keiki.Core (HsPred)" + , "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))" + , "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)" + ] + ++ ["import Data.Text (Text)" | hasSnapshot a] + ++ ["import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)" | hasSnapshot a] + ++ [ "import Keiro.Stream qualified as Stream" + , "" + , "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped)." + , "-- Entity streams are '-' via Keiro.Stream.entityStream." + , "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof." + , lowerFirst (aName a) <> "Category :: Stream.StreamCategory a" + , lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName + , "" + , "type " <> aName a <> "EventStreamDef =" + , " EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event" + , "" + , "type " <> aName a <> "EventStream =" + , " ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event" + , "" + , lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef" + , lowerFirst (aName a) <> "EventStreamDef =" + , " EventStream" + , " { transducer = " <> lowerFirst (aName a) <> "Transducer" + , " , initialState = " <> initialVertex a + , " , initialRegisters = initial" <> aName a <> "Regs" + , " , eventCodec = " <> lowerFirst (aName a) <> "Codec" + , " , resolveStreamName = Stream.streamName" + , " , snapshotPolicy = " <> snapshotPolicyExpr a + ] + ++ stateCodecFieldLines a + ++ [ " }" + , "" + ] + ++ snapshotFixtureLines a + ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream" + , lowerFirst (aName a) <> "EventStream =" + , " mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef" + ] + where + categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a)) + +snapshotPolicyExpr :: Agg -> Text +snapshotPolicyExpr aggregate = case aSnapshot aggregate of + Nothing -> "Never" + Just snapshot -> case snapPolicy snapshot of + SnapEvery interval -> "Every " <> tshow' interval + SnapOnTerminal -> "OnTerminal" + +stateCodecExpr :: Agg -> Text +stateCodecExpr aggregate = case aSnapshot aggregate of + Nothing -> "Nothing" + Just snapshot -> + "Just (withFoldFingerprint " + <> tshow (aFoldFingerprint aggregate) + <> " (defaultStateCodec " + <> tshow' (snapCodecVersion snapshot) + <> "))" + +stateCodecFieldLines :: Agg -> [Text] +stateCodecFieldLines aggregate = case aSnapshot aggregate of + Nothing -> [" , stateCodec = Nothing"] + Just _ -> + [ " -- The snapshot discriminator composes: the spec's state-codec version (bump it" + , " -- in the spec's `state-codec version=` clause), keiki's register and" + , " -- control-state shape hashes, and this fold fingerprint derived from the" + , " -- spec's transition surface (guards, writes, emits, states, register" + , " -- initials, referenced rules). Spec-visible fold changes invalidate old" + , " -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes" + , " -- module are invisible here: bump `state-codec version=` manually or old" + , " -- snapshots will be served stale." + , " , stateCodec = " <> stateCodecExpr aggregate + ] + +snapshotFixtureLines :: Agg -> [Text] +snapshotFixtureLines aggregate = case aSnapshot aggregate of + Nothing -> [] + Just snapshot -> + [ lowerFirst (aName aggregate) <> "SnapshotFixture :: (Int, Text)" + , lowerFirst (aName aggregate) <> "SnapshotFixture = (" <> tshow' (snapCodecVersion snapshot) <> ", " <> tshow (snapShapeHash snapshot) <> ")" + , "" + ] + +-------------------------------------------------------------------------------- +-- Projection module +-------------------------------------------------------------------------------- + +emitProjection :: Agg -> Text +emitProjection a = case aProjection a of + Nothing -> nl [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"] + Just p -> + nl + [ "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , generatedBanner + , "module " <> aGenPrefix a <> ".Projection" + , " ( " <> lowerFirst (projTable p) <> "Projection" + , " , " <> lowerFirst (projTable p) <> "StatusFor" + , " ) where" + , "" + , "import " <> aGenPrefix a <> ".Domain" + , "import " <> aHolePrefix a <> ".Holes (apply" <> pascal (projTable p) <> ")" + , "import Data.Text (Text)" + , "import Keiro.Projection (InlineProjection (..))" + , "" + , "-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived" + , "-- from the spec's status-map. The read-model SQL that consumes it lives in" + , "-- the hand-owned Holes module (a DB-coupled hole, delegated to codd)." + , projectionTableComment a p + , lowerFirst (projTable p) <> "StatusFor :: " <> aName a <> "Event -> Maybe Text" + , lowerFirst (projTable p) <> "StatusFor = \\case" + , nl (statusArms a p) + , "" + , lowerFirst (projTable p) <> "Projection :: InlineProjection " <> aName a <> "Event" + , lowerFirst (projTable p) <> "Projection =" + , " InlineProjection" + , " { name = " <> tshow (contextNameToProjName a p) + , " , apply = apply" <> pascal (projTable p) + , " }" + ] + +statusArms :: Agg -> ProjectionSpec -> [Text] +statusArms a p = + [ " " <> rcName e <> " {} -> " <> statusFor e + | e <- aEvents a + ] + ++ [" _ -> Nothing" | hasWildcard] + where + pairs = maybe [] mapPairs (projStatusMap p) + statusFor e = case lookup (rcName e) pairs of + Just value -> "Just " <> tshow value + Nothing -> "Nothing" + -- A wildcard is only needed if some event is uncovered; otherwise every arm + -- is explicit and a wildcard would be redundant (and -Wall would warn). + hasWildcard = False + +contextNameToProjName :: Agg -> ProjectionSpec -> Text +contextNameToProjName a p = contextKebab a <> "-" <> projTable p <> "-inline" + +contextKebab :: Agg -> Text +contextKebab = kebabFromPascal . aCtxPascal + +projectionReadModel :: Agg -> Maybe ReadModelNode +projectionReadModel aggregate = do + projection <- aProjection aggregate + find ((== projTable projection) . rmName) (aReadModels aggregate) + +projectionTableComment :: Agg -> ProjectionSpec -> Text +projectionTableComment aggregate projection = case projectionReadModel aggregate of + Nothing -> + "-- WARNING: no readmodel node declares '" + <> projTable projection + <> "'; unqualified SQL depends on search_path." + Just readModel -> + "-- Qualified table " + <> qualifiedTableLiteral readModel + <> "; use " + <> genPrefixFor (aContext aggregate) (pascal (rmName readModel)) + <> ".ReadModelTable." + <> readModelStem readModel + <> "QualifiedTable." + +-------------------------------------------------------------------------------- +-- Holes module (create-if-absent) +-------------------------------------------------------------------------------- + +emitHoles :: Agg -> Text +emitHoles a = + nl + [ "{-# LANGUAGE BlockArguments #-}" + , "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE OverloadedRecordDot #-}" + , "{-# LANGUAGE QualifiedDo #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never" + , "-- overwrites it. Fill the transducer body (and any other holes) against the" + , "-- generated signatures, then run the harness to confirm behaviour." + , "module " <> aHolePrefix a <> ".Holes" + , " ( " <> lowerFirst (aName a) <> "Transducer" + , holeProjectionExport a + , holeUpcasterExports a + , " ) where" + , "" + , "import " <> aGenPrefix a <> ".Domain" + , "import Keiki.Builder ((=:))" + , "import qualified Keiki.Builder as B" + , "import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))" + , holeUpcasterImports a + , holeProjectionImports a + , "" + , "-- HOLE: the transducer body. Reproduce the structure below, replacing each" + , "-- `-- HOLE` line with the keiki symbolic operators it describes." + , lowerFirst (aName a) <> "Transducer" + , " :: SymTransducer" + , " (HsPred " <> aName a <> "Regs " <> aName a <> "Command)" + , " " <> aName a <> "Regs" + , " " <> aVertexType a + , " " <> aName a <> "Command" + , " " <> aName a <> "Event" + , lowerFirst (aName a) <> "Transducer =" + , " B.buildTransducer " <> initialVertex a <> " initial" <> aName a <> "Regs isTerminal do" + , nl (concatMap (fromBlock a) (groupBySource a)) + , " where" + , " isTerminal = \\case" + , nl [" " <> vertexCtor a (stName s) <> " -> True" | s <- aStates a, stTerminal s] + , " _ -> False" + , holeProjectionStub a + , holeUpcasterStubs a + ] + +-- | Export, import, and stub the per-event upcaster holes (EP-2 evolution). +holeUpcasterExports :: Agg -> Text +holeUpcasterExports a = case upcasterEntries a of + [] -> "" + es -> nl [" , " <> fn | (_, _, fn) <- es] + +holeUpcasterImports :: Agg -> Text +holeUpcasterImports a = case upcasterEntries a of + [] -> "" + _ -> nl ["import Data.Aeson (Value)", "import Data.Text (Text)"] + +holeUpcasterStubs :: Agg -> Text +holeUpcasterStubs a = case upcasterEntries a of + [] -> "" + es -> + nl $ + concat + [ [ "" + , "-- HOLE upcaster: this hole receives ONLY " <> eventName <> " payloads stored at" + , "-- aggregate schema version " <> tshow' source <> "; other event kinds pass through the" + , "-- generated rung dispatch automatically. Bring this payload up one version and decide" + , "-- the default/derivation for any field added at the new version here." + , fn <> " :: Value -> Either Text Value" + , fn <> " _ = Left \"HOLE: upcaster not implemented\"" + ] + | (source, eventName, fn) <- es + ] + +holeProjectionExport :: Agg -> Text +holeProjectionExport a = case aProjection a of + Nothing -> " -- (no projection)" + Just p -> " , apply" <> pascal (projTable p) + +holeProjectionImports :: Agg -> Text +holeProjectionImports aggregate = case projectionReadModel aggregate of + Nothing -> "" + Just readModel -> + "import " + <> genPrefixFor (aContext aggregate) (pascal (rmName readModel)) + <> ".ReadModelTable (" + <> readModelStem readModel + <> "QualifiedTable)" + +holeProjectionStub :: Agg -> Text +holeProjectionStub a = case aProjection a of + Nothing -> "" + Just p -> + nl + ( [ "" + , "-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the" + , "-- pure event->status mapping is generated as " <> lowerFirst (projTable p) <> "StatusFor)." + ] + ++ projectionGuidance + ++ [ "apply" <> pascal (projTable p) <> " :: " <> aName a <> "Event -> recorded -> txn ()" + , "apply" <> pascal (projTable p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> projTable p <> " projection apply\"" + ] + ) + where + projectionGuidance = case projectionReadModel a of + Nothing -> + ["-- WARNING: no readmodel node declares this table's schema; unqualified SQL depends on search_path."] + Just readModel -> + [ "-- Table: " <> qualifiedTableLiteral readModel <> ". Use " <> readModelStem readModel <> "QualifiedTable; never rely on search_path." + , "-- Declared columns:" + ] + ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) + projectionTableUse = case projectionReadModel a of + Nothing -> "" + Just readModel -> readModelStem readModel <> "QualifiedTable `seq` " + +-- Group transitions by source state, preserving order, for the B.from blocks. +groupBySource :: Agg -> [(Text, [Transition])] +groupBySource a = go [] (transitionsOf a) + where + go acc [] = reverse acc + go acc (t : ts) = + let src = tSource t + (same, rest) = span ((== src) . tSource) ts + in go ((src, t : same) : acc) rest + +-- We don't keep the original Aggregate around in Agg, so reconstruct +-- transitions from a stored field. (Filled in resolveAgg via aTransitions.) +transitionsOf :: Agg -> [Transition] +transitionsOf = aTransitions + +fromBlock :: Agg -> (Text, [Transition]) -> [Text] +fromBlock a (src, ts) = + [ " B.from " <> vertexCtor a src <> " do" + ] + ++ concatMap (onCmdBlock a) ts + +onCmdBlock :: Agg -> Transition -> [Text] +onCmdBlock a t = + [ " B.onCmd inCtor" <> tCommand t <> " $ \\d -> B.do" + ] + -- Plan 143: the mode is structural, not hole-owned — a replay-only + -- transition lowers to B.replayOnly (keiki ReplayOnly edge). + ++ [" B.replayOnly" | tMode t == TmReplayOnly] + ++ maybe [] (\g -> [" -- HOLE guard: " <> renderGuard g]) (tGuard t) + ++ [" -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- tWrites t] + ++ [" -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- tEmits t] + ++ [" B.goto " <> vertexCtor a (tGoto t)] + +-------------------------------------------------------------------------------- +-- Field categories and shared helpers +-------------------------------------------------------------------------------- + +data FieldCat + = IdCat + | EnumCat + | MappedStructuralCat !StructuralDecl !ResolvedMappedShape + | MappedOpaqueCat !OpaqueDecl + | OtherCat + deriving stock (Eq, Show) + +fieldCat :: Agg -> Text -> FieldCat +fieldCat a ty + | ty `elem` map idName (aIds a) = IdCat + | ty `elem` map enumName (aEnums a) = EnumCat + | Just (ResolvedStructural declaration shape) <- mappedDeclFor a ty = MappedStructuralCat declaration shape + | Just (ResolvedOpaque declaration) <- mappedDeclFor a ty = MappedOpaqueCat declaration + | otherwise = OtherCat + +-- | The first constructor of a declared enum, used to build sample values. +firstEnumCtor :: Agg -> Text -> Maybe Text +firstEnumCtor a ty = + case [c | e <- aEnums a, enumName e == ty, (c, _) <- take 1 (enumCtors e)] of + (c : _) -> Just c + [] -> Nothing + +vertexCtor :: Agg -> Text -> Text +vertexCtor a s = aName a <> s + +initialVertex :: Agg -> Text +initialVertex a = case aStates a of + (s : _) -> vertexCtor a (stName s) + [] -> aName a <> "Init" + +generatedBanner :: Text +generatedBanner = "-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec." + +nodeOrigin :: Text -> Text -> Loc -> Text +nodeOrigin nodeKind nodeName loc = + nodeKind <> " " <> nodeName <> case unLoc loc of + 0 -> "" + line -> " (line " <> tshow' line <> ")" + +{- | Conditions that the deterministic emitters cannot lower faithfully. The +pre-write scaffold pipeline treats each returned message as a refusal. The +list is extended alongside the policy and type lowering milestones. +-} +scaffoldRefusals :: Spec -> [Text] +scaffoldRefusals spec = + concatMap aggregateRefusals aggregates + <> concatMap contractRefusals contracts + <> concatMap publisherRefusals publishers + where + aggregates = [aggregate | NAggregate aggregate <- specNodes spec] + contracts = [contract | NContract contract <- specNodes spec] + publishers = [publisher | NPublisher publisher <- specNodes spec] + idTypes = map idName (specIds spec) + enumTypes = map enumName (specEnums spec) + mappedTypes = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> map unMappedKey (Map.keys (tgDeclarations graph)) + mappedDeclaration typeName = case resolveTypeGraph spec of + Left _ -> Nothing + Right graph -> Map.lookup (MappedKey typeName) (tgDeclarations graph) + enumCtorsFor ty = case [map fst (enumCtors enum) | enum <- specEnums spec, enumName enum == ty] of + ctors : _ -> ctors + [] -> [] + aggregateRefusals aggregate = + [ "AggregateEmpty: aggregate '" <> aggName aggregate <> "' must declare at least one command, event, and transition" + | null (aggCommands aggregate) || null (aggEvents aggregate) || null (aggTransitions aggregate) + ] + <> concatMap (registerRefusals aggregate) (aggRegs aggregate) + <> [ "FieldTypeUnrepresentable: aggregate '" <> aggName aggregate <> "' field '" <> fieldName field <> "' has unsupported explicit type '" <> ty <> "'" + | field <- aggregateFields aggregate + , Just ty <- [fieldType field] + , not (supportedType aggregate ty) + ] + registerRefusals aggregate reg = + [ "RegTypeUnsupported: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' has unsupported type '" <> regType reg <> "'" + | not (supportedType aggregate (regType reg)) + ] + <> [ "RegTextInitialNotQuoted: aggregate '" <> aggName aggregate <> "' Text register '" <> regName reg <> "' must use a quoted initial" + | regType reg == "Text" + , RegInitBare _ <- [regInitial reg] + ] + <> [ "RegInitialNotEnumCtor: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' must start at a constructor of enum '" <> regType reg <> "'" + | regType reg `elem` enumTypes + , case regInitial reg of + RegInitBare value -> value `notElem` enumCtorsFor (regType reg) + RegInitText _ -> True + ] + <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Bool register '" <> regName reg <> "' must start at True or False" + | regType reg == "Bool" + , case regInitial reg of RegInitBare value -> value `notElem` ["True", "False"]; RegInitText _ -> True + ] + <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Int register '" <> regName reg <> "' must start at an integer literal" + | regType reg == "Int" + , case regInitial reg of RegInitBare value -> (readMaybe (T.unpack value) :: Maybe Int) == Nothing; RegInitText _ -> True + ] + <> [ "MappedRegisterInitialMissing: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' requires the mapped declaration's initial symbol" + | Just declaration <- [mappedDeclaration (regType reg)] + , mappedInitial declaration == Nothing + ] + aggregateFields aggregate = + concatMap cmdFields (aggCommands aggregate) + <> concat [fields | event <- aggEvents aggregate, EventFields fields <- [evBody event]] + supportedType aggregate ty = + ty `elem` (["Text", "Int", "Bool", aggName aggregate <> "Vertex"] <> idTypes <> enumTypes <> mappedTypes) contractRefusals contract = [ "ContractEmpty: contract '" <> ctrName contract <> "' must declare at least one event" | null (ctrEvents contract) diff --git a/src/Keiro/Dsl/ScaffoldRecord.hs b/src/Keiro/Dsl/ScaffoldRecord.hs --- a/src/Keiro/Dsl/ScaffoldRecord.hs +++ b/src/Keiro/Dsl/ScaffoldRecord.hs @@ -1,6 +1,7 @@ -{- | Versioned, dependency-free persistence for the files produced by one -successful scaffold run. Unknown header fields are ignored so v1 readers can -consume records extended by later tool versions. +{- | Versioned persistence for the files and mapped consumer identities used by +one successful scaffold run. Unknown header fields are ignored so v1 readers +can consume records extended by later tool versions. Mapping rows are canonical +single-line JSON after a @mapping @ prefix; old readers ignore that row kind. -} module Keiro.Dsl.ScaffoldRecord ( ScaffoldRecord (..), @@ -9,8 +10,14 @@ recordFileName, ) where +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as BL +import Data.List (nub) import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as Text +import Keiro.Dsl.ExplainBindings (BindingHole (..)) +import Keiro.Dsl.MappedConsumer (MappingIdentity (..)) import Keiro.Dsl.Scaffold (ModuleKind (..)) import System.FilePath (isAbsolute, splitDirectories) @@ -19,6 +26,8 @@ , recModuleRoot :: !Text , recLayout :: !Text , recFiles :: ![(ModuleKind, FilePath)] + , recMappings :: ![MappingIdentity] + , recBindingObligations :: ![BindingHole] } deriving stock (Eq, Show) @@ -31,10 +40,16 @@ , "layout: " <> recLayout record ] <> map renderFile (recFiles record) + <> map renderMapping (recMappings record) + <> map renderBindingObligation (recBindingObligations record) where rootLabel = if T.null (recModuleRoot record) then "(none)" else recModuleRoot record renderFile (Generated, path) = "generated " <> T.pack path renderFile (HoleStub, path) = "hole " <> T.pack path + renderMapping mapping = + "mapping " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode mapping)) + renderBindingObligation obligation = + "binding " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode obligation)) {- | Parse a v1 record. The version header and the three required fields must be present exactly once. Unknown lines are ignored for forward compatibility; @@ -48,13 +63,20 @@ rootLabel <- exactlyOne "module-root: " rows layout <- exactlyOne "layout: " rows files <- traverse parseFile (filter isFileRow rows) - pure - ScaffoldRecord - { recSpecPath = specPath - , recModuleRoot = if rootLabel == "(none)" then "" else rootLabel - , recLayout = layout - , recFiles = files - } + mappings <- traverse parseMapping (filter ("mapping " `T.isPrefixOf`) rows) + bindingEntries <- traverse parseBindingObligation (filter ("binding " `T.isPrefixOf`) rows) + if hasDuplicateMappingNames mappings || hasDuplicateBindingObligations bindingEntries + then Nothing + else + pure + ScaffoldRecord + { recSpecPath = specPath + , recModuleRoot = if rootLabel == "(none)" then "" else rootLabel + , recLayout = layout + , recFiles = files + , recMappings = mappings + , recBindingObligations = bindingEntries + } _ -> Nothing where exactlyOne prefix rows = case [value | row <- rows, Just value <- [T.stripPrefix prefix row]] of @@ -70,6 +92,25 @@ in if null path || isAbsolute path || ".." `elem` splitDirectories path then Nothing else Just (fileKind, path) + parseMapping row = do + payload <- T.stripPrefix "mapping " row + Aeson.decodeStrict' (Text.encodeUtf8 payload) + parseBindingObligation row = do + payload <- T.stripPrefix "binding " row + Aeson.decodeStrict' (Text.encodeUtf8 payload) + hasDuplicateMappingNames mappings = + let names = map mappingSpecName mappings + in length names /= length (nub names) + hasDuplicateBindingObligations obligations = + let keys = map bindingKey obligations + in length keys /= length (nub keys) + bindingKey hole = + ( holeMappedName hole + , holeModule hole + , holeSymbol hole + , holeKind hole + , holePath hole + ) recordFileName :: Text -> FilePath recordFileName context = "keiro-dsl-scaffold-record." <> T.unpack context <> ".txt" diff --git a/src/Keiro/Dsl/ScaffoldRun.hs b/src/Keiro/Dsl/ScaffoldRun.hs --- a/src/Keiro/Dsl/ScaffoldRun.hs +++ b/src/Keiro/Dsl/ScaffoldRun.hs @@ -5,9 +5,12 @@ Refusal (..), WriteDisposition (..), StaleModule (..), + MappingDrift (..), ScaffoldReport (..), scaffoldModules, + scaffoldModulesWithGoldens, planScaffold, + planScaffoldWithGoldens, executeScaffold, renderRefusals, renderScaffoldReport, @@ -19,11 +22,15 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligationKind (..), bindingHoles) +import Keiro.Dsl.Goldens (GoldenPayload) import Keiro.Dsl.Grammar (Node (..), Spec (..)) -import Keiro.Dsl.Harness (harnessFor, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow) +import Keiro.Dsl.Harness (harnessForWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow) import Keiro.Dsl.Manifest (moduleNameOf, renderManifest) +import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan) import Keiro.Dsl.Scaffold import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord) +import Keiro.Dsl.TypeGraph (MappedKey (..), TypeGraph (..), UseSite (..), resolveTypeGraph) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory, ()) @@ -32,6 +39,7 @@ | FirewallBreach ![(FilePath, Text, Int)] | LoweringRefusal ![Text] | MissingGeneratedBanner ![FilePath] + | ImportCycle ![Text] deriving stock (Eq, Show) data WriteDisposition = Overwritten | Created | Skipped @@ -43,6 +51,13 @@ } deriving stock (Eq, Show) +data MappingDrift = MappingDrift + { driftSpecName :: !Text + , driftPrevious :: !(Maybe MappingIdentity) + , driftCurrent :: !(Maybe MappingIdentity) + } + deriving stock (Eq, Show) + data ScaffoldReport = ScaffoldReport { reportSpecPath :: !FilePath , reportOutDir :: !FilePath @@ -52,6 +67,10 @@ , reportRecordPath :: !FilePath , reportPreviousSpecPath :: !(Maybe Text) , reportStale :: ![StaleModule] + , reportConsumerPlan :: !ConsumerPlan + , reportConstraintPlan :: ![Text] + , reportMappingDrift :: ![MappingDrift] + , reportNewHoles :: ![BindingHole] } deriving stock (Eq, Show) @@ -59,37 +78,93 @@ this registry in one place prevents the CLI and tests from drifting apart. -} scaffoldModules :: Context -> Spec -> [ScaffoldModule] -scaffoldModules ctx spec = - concat - [ case node of - NAggregate agg -> scaffoldAggregate ctx spec agg <> harnessFor ctx spec agg - NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process - NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router - NContract contract -> scaffoldContract ctx contract - NIntake intake -> scaffoldIntake ctx intake - NPublisher publisher -> scaffoldPublisher ctx publisher - NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue - NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel - NWorkflow workflow -> harnessWorkflow ctx workflow - NEmit _ -> [] - NPgmqDispatch _ -> [] - NOperation _ -> [] - | node <- specNodes spec - ] +scaffoldModules = scaffoldModulesWithGoldens [] +scaffoldModulesWithGoldens :: [GoldenPayload] -> Context -> Spec -> [ScaffoldModule] +scaffoldModulesWithGoldens goldens ctx spec = + scaffoldStructural ctx spec + <> scaffoldReplayAudit ctx spec + <> concat + [ case node of + NAggregate agg -> scaffoldAggregate ctx spec agg <> harnessForWithGoldens goldens ctx spec agg + NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process + NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router + NContract contract -> scaffoldContract ctx contract + NIntake intake -> scaffoldIntake ctx intake + NPublisher publisher -> scaffoldPublisher ctx publisher + NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue + NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel + NWorkflow workflow -> harnessWorkflow ctx workflow + NEmit _ -> [] + NPgmqDispatch _ -> [] + NOperation _ -> [] + | node <- specNodes spec + ] + {- | Run every pure refusal gate. A successful result is the exact write set; a refusal has no write set and therefore cannot be accidentally executed. -} planScaffold :: Context -> Spec -> Either [Refusal] [ScaffoldModule] -planScaffold ctx spec = - let modules = scaffoldModules ctx spec +planScaffold = planScaffoldWithGoldens [] + +planScaffoldWithGoldens :: [GoldenPayload] -> Context -> Spec -> Either [Refusal] [ScaffoldModule] +planScaffoldWithGoldens goldens ctx spec = + let modules = scaffoldModulesWithGoldens goldens ctx spec breaches = firewallBreaches modules refusals = collisionRefusals modules + <> dependencyRefusals ctx spec modules <> [FirewallBreach breaches | not (null breaches)] <> [LoweringRefusal lowering | let lowering = scaffoldRefusals spec, not (null lowering)] in if null refusals then Right modules else Left refusals +dependencyRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal] +dependencyRefusals ctx spec modules = collisionWithConsumers <> namespaceCycles + where + plan = consumerPlan spec + generatedByName = Map.fromList [(moduleNameOf (modulePath moduleValue), moduleValue) | moduleValue <- modules, kind moduleValue == Generated] + collisionWithConsumers = + [ PathCollision + (modulePath generated) + [origin generated, "consumer module " <> consumerModule] + | consumerModule <- consumerModules plan + , Just generated <- [Map.lookup consumerModule generatedByName] + ] + namespaceCycles = + [ ImportCycle [importer, consumerModule, importer] + | consumerModule <- consumerModules plan + , generatedNamespaceOwned ctx consumerModule + , importer <- take 1 (importersOf consumerModule modules <> [contextGeneratedRoot ctx]) + ] + +generatedNamespaceOwned :: Context -> Text -> Bool +generatedNamespaceOwned ctx consumerModule = case placement ctx of + GeneratedPrefix -> contextGeneratedRoot ctx `T.isPrefixOf` consumerModule + CollocatedLeaf -> + (root <> contextSegment <> ".") `T.isPrefixOf` consumerModule + && ".Generated" `T.isInfixOf` consumerModule + where + root = if T.null (moduleRoot ctx) then "" else moduleRoot ctx <> "." + contextSegment = pascalFromKebab (contextName ctx) + +contextGeneratedRoot :: Context -> Text +contextGeneratedRoot ctx = case placement ctx of + GeneratedPrefix -> root <> "Generated." <> contextSegment + CollocatedLeaf -> root <> contextSegment <> ".Generated" + where + root = if T.null (moduleRoot ctx) then "" else moduleRoot ctx <> "." + contextSegment = pascalFromKebab (contextName ctx) + +importersOf :: Text -> [ScaffoldModule] -> [Text] +importersOf imported = + map (moduleNameOf . modulePath) + . filter (any (importsModule imported) . T.lines . moduleText) + +importsModule :: Text -> Text -> Bool +importsModule expected line = case T.words (T.strip line) of + "import" : rest -> expected `elem` rest + _ -> False + collisionRefusals :: [ScaffoldModule] -> [Refusal] collisionRefusals modules = [ PathCollision (modulePath first) (map origin (first : rest)) @@ -115,11 +190,15 @@ let recordPath = out recordFileName (specContext spec) previousRecord <- readRecord recordPath stale <- maybe (pure []) (existingStale out modules) previousRecord + let currentConsumerPlan = consumerPlan spec + drift = maybe [] (mappingDrift (consumerMappings currentConsumerPlan) . recMappings) previousRecord + currentObligations = either (const []) id (bindingHoles spec) + newHoles = maybe [] (newBindingObligations currentObligations . recBindingObligations) previousRecord createDirectoryIfMissing True out dispositions <- mapM (writeModule out) modules let manifestPath = out ("keiro-dsl-manifest." <> T.unpack (specContext spec) <> ".txt") TIO.writeFile manifestPath (renderManifest (T.pack specPath) modules spec) - TIO.writeFile recordPath (renderRecord (currentRecord specPath ctx modules)) + TIO.writeFile recordPath (renderRecord (currentRecord specPath ctx spec modules)) pure $ Right ScaffoldReport @@ -131,8 +210,54 @@ , reportRecordPath = recordPath , reportPreviousSpecPath = recSpecPath <$> previousRecord , reportStale = stale + , reportConsumerPlan = currentConsumerPlan + , reportConstraintPlan = constraintPlan spec currentConsumerPlan + , reportMappingDrift = drift + , reportNewHoles = newHoles } +constraintPlan :: Spec -> ConsumerPlan -> [Text] +constraintPlan spec plan = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> + let registerRoots = + Set.fromList + [ key + | RootRegister _ _ key <- tgUseSites graph + ] + in map (constraintFor registerRoots) (consumerMappings plan) + where + constraintFor registerRoots mapping = + mappingSpecName mapping + <> ": " + <> T.intercalate ", " (baseConstraints mapping <> registerConstraints registerRoots mapping) + baseConstraints StructuralMapping{} = ["Eq", "Show", "CanonicalTypeName", "StructuralBinding"] + baseConstraints OpaqueMapping{} = ["Eq", "Show", "ToJSON", "FromJSON"] + registerConstraints roots mapping + | MappedKey (mappingSpecName mapping) `Set.member` roots = ["register initial", "snapshot ToJSON", "snapshot FromJSON"] + | otherwise = [] + +mappingDrift :: [MappingIdentity] -> [MappingIdentity] -> [MappingDrift] +mappingDrift current previous = + [ MappingDrift name old new + | name <- Set.toAscList (Map.keysSet oldByName <> Map.keysSet newByName) + , let old = Map.lookup name oldByName + , let new = Map.lookup name newByName + , old /= new + ] + where + oldByName = Map.fromList [(mappingSpecName mapping, mapping) | mapping <- previous] + newByName = Map.fromList [(mappingSpecName mapping, mapping) | mapping <- current] + +newBindingObligations :: [BindingHole] -> [BindingHole] -> [BindingHole] +newBindingObligations current previous = + [ obligation + | obligation <- current + , obligation `Set.notMember` previousSet + ] + where + previousSet = Set.fromList previous + readRecord :: FilePath -> IO (Maybe ScaffoldRecord) readRecord path = do exists <- doesFileExist path @@ -147,13 +272,15 @@ exists <- doesFileExist (out path) pure [StaleModule fileKind path | exists] -currentRecord :: FilePath -> Context -> [ScaffoldModule] -> ScaffoldRecord -currentRecord specPath ctx modules = +currentRecord :: FilePath -> Context -> Spec -> [ScaffoldModule] -> ScaffoldRecord +currentRecord specPath ctx spec modules = ScaffoldRecord { recSpecPath = T.pack specPath , recModuleRoot = moduleRoot ctx , recLayout = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated" , recFiles = [(kind m, modulePath m) | m <- modules] + , recMappings = consumerMappings (consumerPlan spec) + , recBindingObligations = either (const []) id (bindingHoles spec) } missingGeneratedBanners :: FilePath -> [ScaffoldModule] -> IO [FilePath] @@ -204,6 +331,11 @@ ] <> map (" " <>) (map T.pack paths) <> [" (adopted as hand code? move it, or re-run with --force-generated-overwrite)", "nothing was written"] + render (ImportCycle path) = + [ "error: generated/consumer import cycle -- refusing to scaffold; nothing was written" + , " " <> T.intercalate " -> " path + , " keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural" + ] renderScaffoldReport :: ScaffoldReport -> [Text] renderScaffoldReport report = @@ -212,9 +344,14 @@ <> map moduleLine dispositions <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)" , harnessLine + , dependencyLine , "manifest: " <> T.pack (reportManifestPath report) + , "record: " <> T.pack (reportRecordPath report) ] <> previousSpecNote + <> constraintSection + <> newHolesSection + <> mappingDriftSection <> staleSection where ctx = reportContext report @@ -242,6 +379,23 @@ harnessLine = case harnesses of [] -> "harness: (none emitted)" _ -> "harness: run `cabal test ` over " <> T.unwords harnesses + dependencyLine = + "dependency plan: consumer packages " + <> renderBracketed (consumerPackages (reportConsumerPlan report)) + <> ", consumer modules " + <> renderBracketed (consumerModules (reportConsumerPlan report)) + constraintSection = case reportConstraintPlan report of + [] -> [] + constraints -> "constraint plan:" : map (" " <>) constraints + newHolesSection = case reportNewHoles report of + [] -> [] + obligations -> + ["newly required holes since last scaffold: " <> tshow (length obligations)] + <> concatMap obligationLines obligations + obligationLines hole = + [ " " <> holeModule hole + , " " <> holeSignature hole <> " (" <> obligationKindLabel (holeKind hole) <> ")" + ] previousSpecNote = case reportPreviousSpecPath report of Just previous | previous /= T.pack (reportSpecPath report) -> @@ -249,6 +403,16 @@ , " specs sharing context " <> contextName ctx <> " in one --out also share " <> T.pack (reportManifestPath report) ] _ -> [] + mappingDriftSection = case reportMappingDrift report of + [] -> [] + drifts -> + ["mapping drift: " <> tshow (length drifts) <> " declaration(s) changed since the previous scaffold:"] + <> concatMap driftLines drifts + driftLines drift = + [ " " <> driftSpecName drift + , " previous: " <> maybe "(absent)" renderMappingIdentity (driftPrevious drift) + , " current: " <> maybe "(absent)" renderMappingIdentity (driftCurrent drift) + ] staleSection = case reportStale report of [] -> [] stale -> @@ -259,6 +423,38 @@ staleLine stale = case staleKind stale of Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + +obligationKindLabel :: BindingObligationKind -> Text +obligationKindLabel BindingValue = "binding" +obligationKindLabel FixtureValue = "fixtures" +obligationKindLabel InitialValue = "initial-value" + +renderBracketed :: [Text] -> Text +renderBracketed values = "[" <> T.intercalate ", " values <> "]" + +renderMappingIdentity :: MappingIdentity -> Text +renderMappingIdentity StructuralMapping{mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} = + "structural " + <> mappingPackage + <> ":" + <> mappingModule + <> "." + <> mappingType + <> " binding=" + <> mappingBindingSymbol + <> " version=" + <> mappingBindingVersion +renderMappingIdentity OpaqueMapping{mappingPackage, mappingModule, mappingType, mappingCodecIdentity, mappingCodecVersion} = + "opaque " + <> mappingPackage + <> ":" + <> mappingModule + <> "." + <> mappingType + <> " codec=" + <> mappingCodecIdentity + <> " version=" + <> mappingCodecVersion tshow :: (Show a) => a -> Text tshow = T.pack . show diff --git a/src/Keiro/Dsl/TypeGraph.hs b/src/Keiro/Dsl/TypeGraph.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/TypeGraph.hs @@ -0,0 +1,664 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +{- | Checked, resolved consumer-owned mapped types. Parser declarations keep +mandatory facts optional so diagnostics can name omissions; this module is +the phase boundary after which missing facts and unresolved references are +unrepresentable. +-} +module Keiro.Dsl.TypeGraph ( + QualifiedValueName (..), + CanonicalTypeId (..), + BindingVersion (..), + CodecIdentity (..), + CodecVersion (..), + mkQualifiedValueName, + mkCanonicalTypeId, + mkBindingVersion, + mkCodecIdentity, + mkCodecVersion, + MappedDeclError (..), + CheckedMappedDecl (..), + StructuralDecl (..), + OpaqueDecl (..), + checkMappedDecl, + MappedKey (..), + ResolvedTypeExpr (..), + ResolvedWireField (..), + ResolvedWireArm (..), + ResolvedMappedShape (..), + ResolvedMappedDecl (..), + TypeGraphError (..), + TypeGraph (..), + UseSite (..), + PathSeg (..), + UsePath (..), + resolveTypeGraph, + usePaths, + renderUsePath, + TypeExprAlgebra (..), + foldTypeExpr, + MappedShapeAlgebra (..), + foldMappedShape, + MappedDeclAlgebra (..), + foldMappedDecl, + wireFingerprint, +) where + +import Data.Bifunctor (first) +import Data.Bits (xor) +import Data.Char (ord) +import Data.Either (partitionEithers) +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word64) +import GHC.Generics (Generic) +import Keiro.Dsl.Grammar +import Numeric (showHex) + +newtype QualifiedValueName = QualifiedValueName {unQualifiedValueName :: Text} + deriving stock (Eq, Ord, Show, Generic) + +newtype CanonicalTypeId = CanonicalTypeId {unCanonicalTypeId :: Text} + deriving stock (Eq, Ord, Show, Generic) + +newtype BindingVersion = BindingVersion {unBindingVersion :: Text} + deriving stock (Eq, Ord, Show, Generic) + +newtype CodecIdentity = CodecIdentity {unCodecIdentity :: Text} + deriving stock (Eq, Ord, Show, Generic) + +newtype CodecVersion = CodecVersion {unCodecVersion :: Text} + deriving stock (Eq, Ord, Show, Generic) + +data MappedDeclError + = MissingHaskellSource !Name + | MissingStructuralBinding !Name + | MissingStructuralBindingVersion !Name + | MissingCanonicalType !Name + | MissingFixtureCases !Name + | MissingOpaqueCodecIdentity !Name + | MissingOpaqueCodecVersion !Name + | EmptyQualifiedValueName !Text + | EmptyCanonicalTypeId !Text + | EmptyBindingVersion !Text + | EmptyCodecIdentity !Text + | EmptyCodecVersion !Text + deriving stock (Eq, Show, Generic) + +mkQualifiedValueName :: Text -> Either MappedDeclError QualifiedValueName +mkQualifiedValueName value + | T.null (T.strip value) = Left (EmptyQualifiedValueName value) + | otherwise = Right (QualifiedValueName value) + +mkCanonicalTypeId :: Text -> Either MappedDeclError CanonicalTypeId +mkCanonicalTypeId value + | T.null (T.strip value) = Left (EmptyCanonicalTypeId value) + | otherwise = Right (CanonicalTypeId value) + +mkBindingVersion :: Text -> Either MappedDeclError BindingVersion +mkBindingVersion value + | T.null (T.strip value) = Left (EmptyBindingVersion value) + | otherwise = Right (BindingVersion value) + +mkCodecIdentity :: Text -> Either MappedDeclError CodecIdentity +mkCodecIdentity value + | T.null (T.strip value) = Left (EmptyCodecIdentity value) + | otherwise = Right (CodecIdentity value) + +mkCodecVersion :: Text -> Either MappedDeclError CodecVersion +mkCodecVersion value + | T.null (T.strip value) = Left (EmptyCodecVersion value) + | otherwise = Right (CodecVersion value) + +data StructuralDecl = StructuralDecl + { sdName :: !Name + , sdHaskell :: !HaskellSource + , sdBinding :: !QualifiedValueName + , sdBindingVersion :: !BindingVersion + , sdCanonical :: !CanonicalTypeId + , sdFixtures :: !QualifiedValueName + , sdInitial :: !(Maybe QualifiedValueName) + , sdLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data OpaqueDecl = OpaqueDecl + { odName :: !Name + , odHaskell :: !HaskellSource + , odCodecIdentity :: !CodecIdentity + , odCodecVersion :: !CodecVersion + , odFixtures :: !QualifiedValueName + , odInitial :: !(Maybe QualifiedValueName) + , odLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data CheckedMappedDecl + = CheckedStructural !StructuralDecl !MappedShape + | CheckedOpaque !OpaqueDecl + deriving stock (Eq, Show, Generic) + +checkMappedDecl :: MappedDecl -> Either (NonEmpty MappedDeclError) CheckedMappedDecl +checkMappedDecl MappedStructural{msName = name, msHaskell = haskell, msBinding = binding, msBindingVersion = bindingVersion, msCanonical = canonical, msFixtures = fixtures, msInitial = initial, msShape = shape, msLoc = loc} = do + checkedHaskell <- require (MissingHaskellSource name) haskell + checkedBinding <- require (MissingStructuralBinding name) binding >>= liftOne . mkQualifiedValueName + checkedBindingVersion <- require (MissingStructuralBindingVersion name) bindingVersion >>= liftOne . mkBindingVersion + checkedCanonical <- require (MissingCanonicalType name) canonical >>= liftOne . mkCanonicalTypeId + checkedFixtures <- require (MissingFixtureCases name) fixtures >>= liftOne . mkQualifiedValueName + checkedInitial <- traverse (liftOne . mkQualifiedValueName) initial + pure + ( CheckedStructural + StructuralDecl + { sdName = name + , sdHaskell = checkedHaskell + , sdBinding = checkedBinding + , sdBindingVersion = checkedBindingVersion + , sdCanonical = checkedCanonical + , sdFixtures = checkedFixtures + , sdInitial = checkedInitial + , sdLoc = loc + } + shape + ) +checkMappedDecl MappedOpaque{moName = name, moHaskell = haskell, moCodecId = codecIdentity, moCodecVersion = codecVersion, moFixtures = fixtures, moInitial = initial, moLoc = loc} = do + checkedHaskell <- require (MissingHaskellSource name) haskell + checkedCodecIdentity <- require (MissingOpaqueCodecIdentity name) codecIdentity >>= liftOne . mkCodecIdentity + checkedCodecVersion <- require (MissingOpaqueCodecVersion name) codecVersion >>= liftOne . mkCodecVersion + checkedFixtures <- require (MissingFixtureCases name) fixtures >>= liftOne . mkQualifiedValueName + checkedInitial <- traverse (liftOne . mkQualifiedValueName) initial + pure + ( CheckedOpaque + OpaqueDecl + { odName = name + , odHaskell = checkedHaskell + , odCodecIdentity = checkedCodecIdentity + , odCodecVersion = checkedCodecVersion + , odFixtures = checkedFixtures + , odInitial = checkedInitial + , odLoc = loc + } + ) + +require :: e -> Maybe a -> Either (NonEmpty e) a +require err = maybe (Left (err :| [])) Right + +liftOne :: Either e a -> Either (NonEmpty e) a +liftOne = first (:| []) + +newtype MappedKey = MappedKey {unMappedKey :: Name} + deriving stock (Eq, Ord, Show, Generic) + +data ResolvedTypeExpr + = RText + | RInt + | RBool + | RNatural + | RTime + | RJson + | ROptional !ResolvedTypeExpr + | RList !ResolvedTypeExpr + | RMap !ResolvedTypeExpr + | RRef !MappedKey + deriving stock (Eq, Show, Generic) + +data ResolvedWireField = ResolvedWireField + { rwfHaskell :: !Name + , rwfKey :: !Text + , rwfType :: !ResolvedTypeExpr + , rwfPresence :: !Presence + , rwfOnMissing :: !(Maybe OnMissing) + , rwfLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data ResolvedWireArm = ResolvedWireArm + { rwaCtor :: !Name + , rwaTag :: !Text + , rwaPayload :: !(Maybe ResolvedTypeExpr) + , rwaLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data ResolvedMappedShape + = RRecord !Name !UnknownFields ![ResolvedWireField] + | REnum ![WireEnum] + | RUnion !UnionEncoding ![ResolvedWireArm] + deriving stock (Eq, Show, Generic) + +data ResolvedMappedDecl + = ResolvedStructural !StructuralDecl !ResolvedMappedShape + | ResolvedOpaque !OpaqueDecl + deriving stock (Eq, Show, Generic) + +data TypeGraphError + = TGDeclError !Name !MappedDeclError + | TGAmbiguousName !Name ![Text] + | TGUnresolvedRef !Name !Name !Loc + | TGRecursive ![Name] + deriving stock (Eq, Show, Generic) + +data UseSite + = RootCommandField !Name !Name !Name !MappedKey + | RootEventField !Name !Name !Name !MappedKey + | RootRegister !Name !Name !MappedKey + deriving stock (Eq, Ord, Show, Generic) + +data PathSeg + = SegField !Name !Text + | SegArm !Name !Text + | SegElem + | SegMapValue + | SegOptional + | SegDecl !Name + deriving stock (Eq, Ord, Show, Generic) + +data UsePath = UsePath + { upRoot :: !UseSite + , upSegments :: ![PathSeg] + } + deriving stock (Eq, Ord, Show, Generic) + +data TypeGraph = TypeGraph + { tgDeclarations :: !(Map MappedKey ResolvedMappedDecl) + , tgReachability :: !(Map MappedKey (Set MappedKey)) + , tgUseSites :: ![UseSite] + } + deriving stock (Eq, Show, Generic) + +resolveTypeGraph :: Spec -> Either (NonEmpty TypeGraphError) TypeGraph +resolveTypeGraph spec = do + checked <- collectChecked (specMapped spec) + rejectMany (ambiguityErrors spec checked) + let keyByName = Map.fromList [(checkedName decl, MappedKey (checkedName decl)) | decl <- checked] + (resolveErrors, resolvedPairs) = partitionEithers (map (resolveCheckedDecl keyByName) checked) + rejectMany resolveErrors + let declarations = Map.fromList resolvedPairs + rejectMany (cycleErrors declarations) + let reachability = Map.mapWithKey (reachableFrom declarations) declarations + pure + TypeGraph + { tgDeclarations = declarations + , tgReachability = reachability + , tgUseSites = collectUseSites keyByName spec + } + +collectChecked :: [MappedDecl] -> Either (NonEmpty TypeGraphError) [CheckedMappedDecl] +collectChecked declarations = + let checked = [(rawName declaration, checkMappedDecl declaration) | declaration <- declarations] + errors = + [ TGDeclError name err + | (name, Left declarationErrors) <- checked + , err <- NE.toList declarationErrors + ] + in case NE.nonEmpty errors of + Just nonEmptyErrors -> Left nonEmptyErrors + Nothing -> Right [declaration | (_, Right declaration) <- checked] + +rejectMany :: [e] -> Either (NonEmpty e) () +rejectMany errors = maybe (Right ()) Left (NE.nonEmpty errors) + +rawName :: MappedDecl -> Name +rawName MappedStructural{msName = name} = name +rawName MappedOpaque{moName = name} = name + +checkedName :: CheckedMappedDecl -> Name +checkedName (CheckedStructural declaration _) = sdName declaration +checkedName (CheckedOpaque declaration) = odName declaration + +ambiguityErrors :: Spec -> [CheckedMappedDecl] -> [TypeGraphError] +ambiguityErrors spec declarations = + [ TGAmbiguousName name origins + | (name, origins) <- Map.toList allOrigins + , length origins > 1 + ] + where + builtins = ["Text", "Int", "Bool", "Natural", "Time", "UTCTime", "Json", "Optional", "List", "Map"] + originPairs = + [(checkedName declaration, "mapped") | declaration <- declarations] + ++ [(idName declaration, "id") | declaration <- specIds spec] + ++ [(enumName declaration, "enum") | declaration <- specEnums spec] + ++ [(name, "built-in") | name <- builtins] + allOrigins = Map.fromListWith (++) [(name, [origin]) | (name, origin) <- originPairs] + +resolveCheckedDecl :: Map Name MappedKey -> CheckedMappedDecl -> Either TypeGraphError (MappedKey, ResolvedMappedDecl) +resolveCheckedDecl _ (CheckedOpaque declaration) = + Right (MappedKey (odName declaration), ResolvedOpaque declaration) +resolveCheckedDecl keyByName (CheckedStructural declaration shape) = do + resolvedShape <- resolveShape keyByName (sdName declaration) shape + pure (MappedKey (sdName declaration), ResolvedStructural declaration resolvedShape) + +resolveShape :: Map Name MappedKey -> Name -> MappedShape -> Either TypeGraphError ResolvedMappedShape +resolveShape keyByName owner (ShapeRecord constructor unknownFields fields) = + RRecord constructor unknownFields <$> traverse resolveField fields + where + resolveField field = + ResolvedWireField + (wfHaskell field) + (wfKey field) + <$> resolveExpr keyByName owner (wireFieldLoc field) (wfType field) + <*> pure (wfPresence field) + <*> pure (wfOnMissing field) + <*> pure (wireFieldLoc field) +resolveShape _ _ (ShapeEnum entries) = Right (REnum entries) +resolveShape keyByName owner (ShapeUnion encoding arms) = + RUnion encoding <$> traverse resolveArm arms + where + resolveArm arm = + ResolvedWireArm + (waCtor arm) + (waTag arm) + <$> traverse (resolveExpr keyByName owner (waLoc arm)) (waPayload arm) + <*> pure (waLoc arm) + +resolveExpr :: Map Name MappedKey -> Name -> Loc -> TypeExpr -> Either TypeGraphError ResolvedTypeExpr +resolveExpr _ _ _ TText = Right RText +resolveExpr _ _ _ TInt = Right RInt +resolveExpr _ _ _ TBool = Right RBool +resolveExpr _ _ _ TNatural = Right RNatural +resolveExpr _ _ _ TTime = Right RTime +resolveExpr _ _ _ TJson = Right RJson +resolveExpr names owner loc (TOptional value) = ROptional <$> resolveExpr names owner loc value +resolveExpr names owner loc (TList value) = RList <$> resolveExpr names owner loc value +resolveExpr names owner loc (TMap value) = RMap <$> resolveExpr names owner loc value +resolveExpr names owner loc (TRef name) = + maybe (Left (TGUnresolvedRef owner name loc)) (Right . RRef) (Map.lookup name names) + +cycleErrors :: Map MappedKey ResolvedMappedDecl -> [TypeGraphError] +cycleErrors declarations = + [ TGRecursive (map unMappedKey keys) + | CyclicSCC keys <- stronglyConnComp vertices + ] + where + vertices = + [ (key, key, Set.toList (directRefs declaration)) + | (key, declaration) <- Map.toList declarations + ] + +directRefs :: ResolvedMappedDecl -> Set MappedKey +directRefs = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> refsInShape shape + , onOpaqueDecl = const Set.empty + } + +refsInShape :: ResolvedMappedShape -> Set MappedKey +refsInShape = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> Set.unions (map (refsInExpr . rwfType) fields) + , onEnum = const Set.empty + , onUnion = \_ arms -> Set.unions (map (maybe Set.empty refsInExpr . rwaPayload) arms) + } + +refsInExpr :: ResolvedTypeExpr -> Set MappedKey +refsInExpr = + foldTypeExpr + TypeExprAlgebra + { onText = Set.empty + , onInt = Set.empty + , onBool = Set.empty + , onNatural = Set.empty + , onTime = Set.empty + , onJson = Set.empty + , onOptional = id + , onList = id + , onMap = id + , onRef = Set.singleton + } + +reachableFrom :: Map MappedKey ResolvedMappedDecl -> MappedKey -> ResolvedMappedDecl -> Set MappedKey +reachableFrom declarations origin declaration = go Set.empty (Set.toList (directRefs declaration)) + where + go visited [] = Set.delete origin visited + go visited (key : rest) + | key `Set.member` visited = go visited rest + | otherwise = + let next = maybe [] (Set.toList . directRefs) (Map.lookup key declarations) + in go (Set.insert key visited) (next ++ rest) + +collectUseSites :: Map Name MappedKey -> Spec -> [UseSite] +collectUseSites keyByName spec = concatMap aggregateSites [aggregate | NAggregate aggregate <- specNodes spec] + where + aggregateSites aggregate = + [ RootCommandField (aggName aggregate) (cmdName command) (fieldName field) key + | command <- aggCommands aggregate + , field <- cmdFields command + , key <- maybeToList (fieldType field >>= (`Map.lookup` keyByName)) + ] + ++ [ RootEventField (aggName aggregate) (evName event) (fieldName field) key + | event <- aggEvents aggregate + , field <- eventFields aggregate event + , key <- maybeToList (fieldType field >>= (`Map.lookup` keyByName)) + ] + ++ [ RootRegister (aggName aggregate) (regName register) key + | register <- aggRegs aggregate + , key <- maybeToList (Map.lookup (regType register) keyByName) + ] + + eventFields aggregate event = case evBody event of + EventFields fields -> fields + EventFromCommand commandName -> + concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName] + + maybeToList = maybe [] pure + +usePaths :: TypeGraph -> Name -> [UsePath] +usePaths graph targetName = case Map.lookup (MappedKey targetName) (tgDeclarations graph) of + Nothing -> [] + Just _ -> + [ UsePath site segments + | site <- tgUseSites graph + , segments <- sitePaths site + ] + where + target = MappedKey targetName + sitePaths site + | siteKey site == target = [[]] + | otherwise = pathsFromDecl Set.empty (siteKey site) + + pathsFromDecl visited current + | current `Set.member` visited = [] + | otherwise = case Map.lookup current (tgDeclarations graph) of + Nothing -> [] + Just declaration -> + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> pathsInShape (Set.insert current visited) shape + , onOpaqueDecl = const [] + } + declaration + + pathsInShape visited = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + concat + [ map (SegField (rwfHaskell field) (rwfKey field) :) (pathsInExpr visited (rwfType field)) + | field <- fields + ] + , onEnum = const [] + , onUnion = \_ arms -> + concat + [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (pathsInExpr visited) (rwaPayload arm)) + | arm <- arms + ] + } + + pathsInExpr visited = \case + RText -> [] + RInt -> [] + RBool -> [] + RNatural -> [] + RTime -> [] + RJson -> [] + ROptional value -> map (SegOptional :) (pathsInExpr visited value) + RList value -> map (SegElem :) (pathsInExpr visited value) + RMap value -> map (SegMapValue :) (pathsInExpr visited value) + RRef key + | key == target -> [[SegDecl (unMappedKey key)]] + | otherwise -> map (SegDecl (unMappedKey key) :) (pathsFromDecl visited key) + +siteKey :: UseSite -> MappedKey +siteKey (RootCommandField _ _ _ key) = key +siteKey (RootEventField _ _ _ key) = key +siteKey (RootRegister _ _ key) = key + +renderUsePath :: UsePath -> Text +renderUsePath (UsePath root segments) = renderRoot root <> T.concat (map renderSegment segments) + where + renderRoot (RootCommandField aggregate command field key) = + aggregate <> " command " <> command <> " ." <> field <> " : " <> unMappedKey key + renderRoot (RootEventField aggregate event field key) = + aggregate <> " event " <> event <> " ." <> field <> " : " <> unMappedKey key + renderRoot (RootRegister aggregate register key) = + aggregate <> " register " <> register <> " : " <> unMappedKey key + + renderSegment (SegField haskellName wireName) + | haskellName == wireName = " ." <> haskellName + | otherwise = " ." <> haskellName <> " as " <> quoted wireName + renderSegment (SegArm _ wireTag) = " arm " <> quoted wireTag + renderSegment SegElem = " []" + renderSegment SegMapValue = " {}" + renderSegment SegOptional = " optional" + renderSegment (SegDecl name) = " : " <> name + quoted value = T.pack (show value) + +data TypeExprAlgebra a = TypeExprAlgebra + { onText :: a + , onInt :: a + , onBool :: a + , onNatural :: a + , onTime :: a + , onJson :: a + , onOptional :: a -> a + , onList :: a -> a + , onMap :: a -> a + , onRef :: MappedKey -> a + } + +foldTypeExpr :: TypeExprAlgebra a -> ResolvedTypeExpr -> a +foldTypeExpr algebra = \case + RText -> onText algebra + RInt -> onInt algebra + RBool -> onBool algebra + RNatural -> onNatural algebra + RTime -> onTime algebra + RJson -> onJson algebra + ROptional value -> onOptional algebra (foldTypeExpr algebra value) + RList value -> onList algebra (foldTypeExpr algebra value) + RMap value -> onMap algebra (foldTypeExpr algebra value) + RRef key -> onRef algebra key + +data MappedShapeAlgebra a = MappedShapeAlgebra + { onRecord :: Name -> UnknownFields -> [ResolvedWireField] -> a + , onEnum :: [WireEnum] -> a + , onUnion :: UnionEncoding -> [ResolvedWireArm] -> a + } + +foldMappedShape :: MappedShapeAlgebra a -> ResolvedMappedShape -> a +foldMappedShape algebra = \case + RRecord constructor unknownFields fields -> onRecord algebra constructor unknownFields fields + REnum entries -> onEnum algebra entries + RUnion encoding arms -> onUnion algebra encoding arms + +data MappedDeclAlgebra a = MappedDeclAlgebra + { onStructuralDecl :: StructuralDecl -> ResolvedMappedShape -> a + , onOpaqueDecl :: OpaqueDecl -> a + } + +foldMappedDecl :: MappedDeclAlgebra a -> ResolvedMappedDecl -> a +foldMappedDecl algebra = \case + ResolvedStructural declaration shape -> onStructuralDecl algebra declaration shape + ResolvedOpaque declaration -> onOpaqueDecl algebra declaration + +wireFingerprint :: TypeGraph -> Name -> Text +wireFingerprint graph name = fnv1a64 (wireDecl Set.empty (MappedKey name)) + where + declarations = tgDeclarations graph + + wireDecl visited key + | key `Set.member` visited = "recursive" + | otherwise = case Map.lookup key declarations of + Nothing -> "missing:" <> unMappedKey key + Just declaration -> + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> wireShape (Set.insert key visited) shape + , onOpaqueDecl = \opaque -> + "opaque(" <> atom (unCodecIdentity (odCodecIdentity opaque)) <> "," <> atom (unCodecVersion (odCodecVersion opaque)) <> ")" + } + declaration + + wireShape visited = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ unknownFields fields -> + "record(" <> renderUnknown unknownFields <> ";" <> T.intercalate ";" (map (wireField visited) (sortOn rwfKey fields)) <> ")" + , onEnum = \entries -> + "enum(" <> T.intercalate ";" (map (atom . weTag) (sortOn weTag entries)) <> ")" + , onUnion = \encoding arms -> + "union(" + <> atom (ueTagField encoding) + <> "," + <> atom (ueContentsField encoding) + <> "," + <> renderUnknown (ueUnknownFields encoding) + <> ";" + <> T.intercalate ";" (map (wireArm visited) (sortOn rwaTag arms)) + <> ")" + } + + wireField visited field = + atom (rwfKey field) + <> ":" + <> wireExpr visited (rwfType field) + <> ":" + <> renderPresence (rwfPresence field) + <> ":" + <> maybe "none" (renderDefault field) (rwfOnMissing field) + + wireArm visited arm = atom (rwaTag arm) <> maybe ":unit" ((":" <>) . wireExpr visited) (rwaPayload arm) + + wireExpr visited = \case + RText -> "text" + RInt -> "int" + RBool -> "bool" + RNatural -> "natural" + RTime -> "time" + RJson -> "json" + ROptional value -> "optional(" <> wireExpr visited value <> ")" + RList value -> "list(" <> wireExpr visited value <> ")" + RMap value -> "map(" <> wireExpr visited value <> ")" + RRef key -> wireDecl visited key + + renderDefault field (OmCtor constructor) = + case rwfType field of + RRef key -> case Map.lookup key declarations of + Just (ResolvedStructural _ (REnum entries)) -> + maybe ("ctor:" <> atom constructor) ("enum:" <>) (lookup constructor [(weCtor entry, atom (weTag entry)) | entry <- entries]) + _ -> "ctor:" <> atom constructor + _ -> "ctor:" <> atom constructor + renderDefault _ value = T.pack (show value) + + renderUnknown RejectUnknown = "reject" + renderUnknown IgnoreUnknown = "ignore" + renderPresence PRequired = "required" + renderPresence POptional = "optional" + atom value = T.pack (show value) + +fnv1a64 :: Text -> Text +fnv1a64 input = + let offsetBasis = 14695981039346656037 :: Word64 + prime = 1099511628211 :: Word64 + digest = T.foldl' (\hash char -> (hash `xor` fromIntegral (ord char)) * prime) offsetBasis input + hexadecimal = showHex digest "" + in T.pack (replicate (16 - length hexadecimal) '0' <> hexadecimal) diff --git a/src/Keiro/Dsl/Validate.hs b/src/Keiro/Dsl/Validate.hs --- a/src/Keiro/Dsl/Validate.hs +++ b/src/Keiro/Dsl/Validate.hs @@ -21,6 +21,7 @@ import Data.Bits (xor) import Data.Char (isControl, isSpace, ord) import Data.List (sortOn) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) @@ -30,6 +31,7 @@ import Data.Word (Word64) import Keiro.Dsl.Grammar import Keiro.Dsl.ReadModelShape (deriveShapeHash) +import Keiro.Dsl.TypeGraph import Numeric (showHex) data Severity = Error | Warning @@ -45,10 +47,14 @@ | GuardAtomOutOfScope | StatusMapNotTotal | ClockSampled - | -- EP-2 (evolution). The first three fire in single-spec @validateSpec@; - -- the last two are emitted by the @diff@ path (they need a prior spec) and - -- live here so the enum is the single registry of evolution rules. + | -- EP-2 (evolution). These codes are shared by single-spec validation and + -- the cross-spec diff path, so the enum remains the single registry of + -- evolution rules. EvtVersionMissingUpcaster + | DuplicateUpcasterSource + | UpcasterChainGap + | DeprecatedEventReplayHazard + | EventRetirementInProgress | DeprecatedEventStillEmitted | WireSchemaVersionMismatch | EvtFieldAddedWithoutBump @@ -183,6 +189,78 @@ | AmbiguousMarkedBenign | AmbiguousFollowsRejectedPolicy | RouterStableNameChanged + | -- Plan 143 (first-class replay-only transitions for guard evolution). + -- The first two fire in single-spec @validateSpec@; the third is the + -- diff-path guard-tightening advisory that prints the computed + -- replay-only twin. + ReplayOnlyEmitsNothing + | ReplayOnlyCommandStillLive + | AggGuardTightened + | AggFoldSurfaceChanged + | RouterDecideSurfaceChanged + | ProcessDecideSurfaceChanged + | ProcessTimerPayloadChanged + | -- MasterPlan 25 / EP-5: append-only codes for findings that were + -- formerly additive but uncoded. + DeclarationAdded + | VersionBumped + | CompatibilityStrengthened + | EnumCtorAdded + | EventRetirementAbandoned + | ContractEventAdded + | ContractTopicAdded + | WorkflowEvolutionGuardAdded + | -- MasterPlan 25 / EP-149 (consumer-owned mapped types). + MappedUnresolvedName + | MappedAmbiguousName + | MappedDuplicateFieldName + | MappedDuplicateWireKey + | MappedDuplicateArmName + | MappedDuplicateWireTag + | MappedNonInjectiveNullability + | MappedRecursiveType + | MappedUnsupportedEncoding + | MappedMissingIngredient + | MappedMissingInitialValue + | MappedInvalidHaskellName + | MappedInvalidIdentity + | MappedImportConflict + | MappedDefaultIllTyped + | MappedGuardUnsupported + | -- MasterPlan 25 / EP-149 mapped evolution codes. + MappedFieldAddedWithDefault + | MappedFieldAddedNoDefault + | MappedFieldRemoved + | MappedFieldTypeChanged + | MappedPresenceChanged + | MappedNullabilityChanged + | MappedDefaultRemoved + | MappedDefaultChanged + | MappedWireKeyChanged + | MappedUnionEncodingChanged + | MappedArmAdded + | MappedArmRemoved + | MappedArmTagChanged + | MappedEnumValueAdded + | MappedEnumValueRemoved + | MappedEnumSpellingChanged + | MappedHaskellSourceChanged + | MappedRecordConstructorChanged + | MappedBindingChanged + | MappedFixturesChanged + | MappedInitialChanged + | MappedCanonicalTypeChanged + | MappedOpaqueCodecChanged + | MappedModeCrossed + | MappedDeclAdded + | MappedDeclRemoved + | -- MasterPlan 25 / EP-152 reporting and migration-evidence codes. + CoverageOpaqueSurface + | CoverageOpaqueBoundaryAdded + | CoverageOpaqueGateExceeded + | CodecCompareDifference + | CodecCompareCoverageGap + | CodecCompareInvalidInput deriving stock (Eq, Show) -- | A line-numbered, structured diagnostic. @@ -222,8 +300,488 @@ -} validateSpec :: Spec -> [Diagnostic] validateSpec spec = - sortOn line (validateNames spec ++ specLevelRules spec ++ concatMap (validateNode spec) (specNodes spec)) + sortOn line (validateNames spec ++ validateMapped spec ++ specLevelRules spec ++ concatMap (validateNode spec) (specNodes spec)) +{- | Validate consumer-owned mapped declarations without inspecting consumer +Haskell. Symbol-shaped facts are checked lexically here; GHC remains the +authority for whether the named packages, modules, values, types, and +instances actually exist with the promised types. +-} +validateMapped :: Spec -> [Diagnostic] +validateMapped spec = + mappedLexicalRules spec + ++ mappedIdentityRules spec + ++ mappedConflictRules spec + ++ case resolveTypeGraph spec of + Left errors -> concatMap (typeGraphDiagnostic spec) (NE.toList errors) + Right graph -> mappedGraphRules spec graph + +typeGraphDiagnostic :: Spec -> TypeGraphError -> [Diagnostic] +typeGraphDiagnostic spec = \case + TGDeclError name declarationError -> + [ mkErr (mappedLine spec name) diagnosticCode $ + "mapped declaration '" <> name <> "': " <> declarationErrorMessage declarationError + ] + where + diagnosticCode = case declarationError of + MissingHaskellSource{} -> MappedMissingIngredient + MissingStructuralBinding{} -> MappedMissingIngredient + MissingStructuralBindingVersion{} -> MappedMissingIngredient + MissingCanonicalType{} -> MappedMissingIngredient + MissingFixtureCases{} -> MappedMissingIngredient + MissingOpaqueCodecIdentity{} -> MappedMissingIngredient + MissingOpaqueCodecVersion{} -> MappedMissingIngredient + EmptyQualifiedValueName{} -> MappedInvalidHaskellName + EmptyCanonicalTypeId{} -> MappedInvalidIdentity + EmptyBindingVersion{} -> MappedInvalidIdentity + EmptyCodecIdentity{} -> MappedInvalidIdentity + EmptyCodecVersion{} -> MappedInvalidIdentity + TGAmbiguousName name origins -> + [ mkErr (mappedLine spec name) MappedAmbiguousName $ + "type name '" <> name <> "' is ambiguous across " <> T.intercalate ", " origins + ] + TGUnresolvedRef owner missing loc -> + [ mkErr (locLine loc) MappedUnresolvedName $ + "mapped declaration '" <> owner <> "' references unresolved mapped type '" <> missing <> "'" + ] + TGRecursive names -> + [ mkErr (mappedLine spec (headOr "" names)) MappedRecursiveType $ + "recursive structural mapping is unsupported: " <> T.intercalate " -> " (names <> take 1 names) + ] + +declarationErrorMessage :: MappedDeclError -> Text +declarationErrorMessage = \case + MissingHaskellSource _ -> "missing complete haskell package/module/type ingredient" + MissingStructuralBinding _ -> "missing binding ingredient; GHC will verify the named value and its type" + MissingStructuralBindingVersion _ -> "missing binding-version ingredient" + MissingCanonicalType _ -> "missing canonical-type ingredient" + MissingFixtureCases _ -> "missing fixtures ingredient; GHC will verify the named FixtureCases value" + MissingOpaqueCodecIdentity _ -> "missing opaque codec identity ingredient" + MissingOpaqueCodecVersion _ -> "missing opaque codec version ingredient" + EmptyQualifiedValueName _ -> "a binding, fixture, or initial symbol is empty; GHC will verify a syntactically valid qualified value" + EmptyCanonicalTypeId _ -> "canonical-type must be non-empty" + EmptyBindingVersion _ -> "binding-version must be non-empty" + EmptyCodecIdentity _ -> "opaque codec identity must be non-empty" + EmptyCodecVersion _ -> "opaque codec version must be non-empty" + +mappedLine :: Spec -> Name -> Int +mappedLine spec name = + maybe 1 (locLine . mappedLoc) (firstMatching ((== name) . mappedName) (specMapped spec)) + +mappedName :: MappedDecl -> Name +mappedName MappedStructural{msName = name} = name +mappedName MappedOpaque{moName = name} = name + +mappedLoc :: MappedDecl -> Loc +mappedLoc MappedStructural{msLoc = loc} = loc +mappedLoc MappedOpaque{moLoc = loc} = loc + +mappedHaskell :: MappedDecl -> Maybe HaskellSource +mappedHaskell MappedStructural{msHaskell = source} = source +mappedHaskell MappedOpaque{moHaskell = source} = source + +mappedCanonical :: MappedDecl -> Maybe Text +mappedCanonical MappedStructural{msCanonical = canonical} = canonical +mappedCanonical MappedOpaque{} = Nothing + +mappedLexicalRules :: Spec -> [Diagnostic] +mappedLexicalRules spec = concatMap declarationRules (specMapped spec) + where + declarationRules declaration = + constructorRule "mapped declaration name" (mappedName declaration) declaration + ++ maybe [] (haskellRules declaration) (mappedHaskell declaration) + ++ qualifiedFacts declaration + ++ shapeConstructorRules declaration + + haskellRules declaration source = + [ invalid declaration $ "Haskell package '" <> hsPackage source <> "' does not follow Cabal package-name grammar" + | not (cabalPackageName (hsPackage source)) + ] + ++ [ invalid declaration $ "Haskell module '" <> hsModule source <> "' must be dot-separated Upper identifiers" + | not (moduleNameSafe (hsModule source)) + ] + ++ [ invalid declaration $ "Haskell type '" <> hsType source <> "' must be an Upper identifier" + | not (constructorSafe (hsType source)) + ] + + qualifiedFacts MappedStructural{msBinding = binding, msFixtures = fixtures, msInitial = initial, msLoc = loc} = + concatMap (qualifiedRule loc) [("binding", binding), ("fixtures", fixtures), ("initial", initial)] + qualifiedFacts MappedOpaque{moFixtures = fixtures, moInitial = initial, moLoc = loc} = + concatMap (qualifiedRule loc) [("fixtures", fixtures), ("initial", initial)] + + qualifiedRule loc (category, value) = case value of + Just symbol + | not (T.null symbol) && not (qualifiedValueSafe symbol) -> + [ mkErr (locLine loc) MappedInvalidHaskellName $ + category <> " symbol '" <> symbol <> "' must be a module path plus a lower-initial value; GHC will verify that it exists with the promised type" + ] + _ -> [] + + shapeConstructorRules declaration = case declaration of + MappedStructural{msShape = ShapeRecord constructor _ fields} -> + constructorRule "record constructor" constructor declaration + ++ [ invalidAt (wireFieldLoc field) $ "record selector '" <> wfHaskell field <> "' must be a lower-initial Haskell identifier" + | field <- fields + , not (lowerIdentifierSafe (wfHaskell field)) + ] + MappedStructural{msShape = ShapeEnum entries} -> + [ invalidAt (weLoc entry) $ "enum constructor '" <> weCtor entry <> "' must be an Upper identifier" + | entry <- entries + , not (constructorSafe (weCtor entry)) + ] + MappedStructural{msShape = ShapeUnion _ arms} -> + [ invalidAt (waLoc arm) $ "union constructor '" <> waCtor arm <> "' must be an Upper identifier" + | arm <- arms + , not (constructorSafe (waCtor arm)) + ] + MappedOpaque{} -> [] + + constructorRule category value declaration = + [ invalid declaration $ category <> " '" <> value <> "' must be an Upper identifier" + | not (constructorSafe value) + ] + invalid declaration detail = invalidAt (mappedLoc declaration) detail + invalidAt loc detail = + mkErr (locLine loc) MappedInvalidHaskellName (detail <> "; this is a syntax check only, and GHC will verify the consumer declaration") + +mappedIdentityRules :: Spec -> [Diagnostic] +mappedIdentityRules spec = + [ mkErr (locLine (mappedLoc declaration)) MappedInvalidIdentity $ + "mapped declaration '" <> mappedName declaration <> "' has an identity/version containing an ASCII control character" + | declaration <- specMapped spec + , value <- identityValues declaration + , T.any asciiControl value + ] + where + identityValues MappedStructural{msBindingVersion = bindingVersion, msCanonical = canonical} = present [bindingVersion, canonical] + identityValues MappedOpaque{moCodecId = codecIdentity, moCodecVersion = codecVersion} = present [codecIdentity, codecVersion] + present = foldr (maybe id (:)) [] + +mappedConflictRules :: Spec -> [Diagnostic] +mappedConflictRules spec = sourceCollisions ++ canonicalCollisions ++ packageCollisions + where + declarations = specMapped spec + sourceFacts = [(declaration, source) | declaration <- declarations, source <- maybeToList (mappedHaskell declaration)] + sourceCollisions = + [ conflict declaration $ + "Haskell target '" <> hsModule source <> "." <> hsType source <> "' is claimed by more than one mapped declaration" + | (declaration, source) <- duplicatesBy (\(_, value) -> (hsModule value, hsType value)) sourceFacts + ] + canonicalFacts = [(declaration, canonical) | declaration <- declarations, canonical <- maybeToList (mappedCanonical declaration), not (T.null canonical)] + canonicalCollisions = + [ conflict declaration $ "canonical-type '" <> canonical <> "' is claimed by more than one mapped declaration" + | (declaration, canonical) <- duplicatesBy snd canonicalFacts + ] + moduleFacts = [(declaration, hsModule source, hsPackage source) | (declaration, source) <- sourceFacts] + packageCollisions = + [ conflict declaration $ + "Haskell module '" <> moduleName <> "' is declared from conflicting packages '" <> oldPackage <> "' and '" <> packageName <> "'" + | (index, (declaration, moduleName, packageName)) <- zip [0 :: Int ..] moduleFacts + , (_, oldModule, oldPackage) <- take index moduleFacts + , oldModule == moduleName + , oldPackage /= packageName + ] + conflict declaration detail = mkErr (locLine (mappedLoc declaration)) MappedImportConflict detail + maybeToList = maybe [] pure + +mappedGraphRules :: Spec -> TypeGraph -> [Diagnostic] +mappedGraphRules spec graph = + concatMap declarationRules (Map.elems (tgDeclarations graph)) + ++ mappedRegisterInitialRules spec graph + ++ if null (specMapped spec) then [] else mappedGuardRules spec graph + where + declarationRules = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \declaration shape -> + foldMappedShape (shapeRules declaration) shape + , onOpaqueDecl = const [] + } + + shapeRules declaration = + MappedShapeAlgebra + { onRecord = \_ _ fields -> + [ mappedError (rwfLoc field) MappedDuplicateFieldName declaration $ + "record selector '" <> rwfHaskell field <> "' is declared more than once" + | field <- duplicatesBy rwfHaskell fields + ] + ++ [ mappedError (rwfLoc field) MappedDuplicateWireKey declaration $ + "record wire key '" <> rwfKey field <> "' is declared more than once" + | field <- duplicatesBy rwfKey fields + ] + ++ [ mappedError (rwfLoc field) MappedUnsupportedEncoding declaration "record wire keys must be non-empty" + | field <- fields + , T.null (rwfKey field) + ] + ++ concatMap (fieldRules declaration) fields + , onEnum = \entries -> + [ mappedError (weLoc entry) MappedDuplicateArmName declaration $ + "enum constructor '" <> weCtor entry <> "' is declared more than once" + | entry <- duplicatesBy weCtor entries + ] + ++ [ mappedError (weLoc entry) MappedDuplicateWireTag declaration $ + "enum wire spelling '" <> weTag entry <> "' is declared more than once" + | entry <- duplicatesBy weTag entries + ] + ++ [ mappedError (weLoc entry) MappedUnsupportedEncoding declaration "enum wire spellings must be non-empty" + | entry <- entries + , T.null (weTag entry) + ] + , onUnion = \encoding arms -> + [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be distinct" + | ueTagField encoding == ueContentsField encoding + ] + ++ [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be non-empty" + | T.null (ueTagField encoding) || T.null (ueContentsField encoding) + ] + ++ [ mappedError (rwaLoc arm) MappedDuplicateArmName declaration $ + "union constructor '" <> rwaCtor arm <> "' is declared more than once" + | arm <- duplicatesBy rwaCtor arms + ] + ++ [ mappedError (rwaLoc arm) MappedDuplicateWireTag declaration $ + "union wire tag '" <> rwaTag arm <> "' is declared more than once" + | arm <- duplicatesBy rwaTag arms + ] + ++ [ mappedError (rwaLoc arm) MappedUnsupportedEncoding declaration "union wire tags must be non-empty" + | arm <- arms + , T.null (rwaTag arm) + ] + ++ concatMap (armRules declaration) arms + } + + fieldRules declaration field = + defaultRules declaration field + ++ [ mappedError (rwfLoc field) MappedNonInjectiveNullability declaration $ + "field '" <> rwfHaskell field <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value" + | hasNonInjectiveOptional graph (rwfType field) + ] + + armRules declaration arm = + [ mappedError (rwaLoc arm) MappedNonInjectiveNullability declaration $ + "union arm '" <> rwaCtor arm <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value" + | payload <- maybeToList (rwaPayload arm) + , hasNonInjectiveOptional graph payload + ] + + defaultRules declaration field = case (rwfPresence field, rwfOnMissing field) of + (PRequired, Just _) -> [illTyped "required fields cannot declare on-missing"] + (POptional, Nothing) -> + [ mappedError (rwfLoc field) MappedMissingIngredient declaration $ + "optional field '" <> rwfHaskell field <> "' is missing its on-missing policy" + ] + (POptional, Just value) + | not (defaultMatches graph (rwfType field) value) -> [illTyped "on-missing value does not match the field type or numeric bounds"] + _ -> [] + where + illTyped detail = + mappedError (rwfLoc field) MappedDefaultIllTyped declaration $ + "field '" <> rwfHaskell field <> "': " <> detail + + mappedError loc diagnosticCode declaration detail = + mkErr (locLine loc) diagnosticCode $ + "mapped declaration '" <> sdName declaration <> "' " <> detail + maybeToList = maybe [] pure + +data DefaultType + = DefaultText + | DefaultInt + | DefaultBool + | DefaultNatural + | DefaultOptional + | DefaultList + | DefaultMap + | DefaultEnum !(Set Name) + | DefaultOther + +defaultMatches :: TypeGraph -> ResolvedTypeExpr -> OnMissing -> Bool +defaultMatches graph expression value = case (defaultType graph expression, value) of + (DefaultText, OmText _) -> True + (DefaultInt, OmInt integer) -> integer >= toInteger (minBound :: Int) && integer <= toInteger (maxBound :: Int) + (DefaultBool, OmBool _) -> True + (DefaultNatural, OmInt integer) -> integer >= 0 + (DefaultOptional, OmNull) -> True + (DefaultList, OmEmptyList) -> True + (DefaultMap, OmEmptyMap) -> True + (DefaultEnum constructors, OmCtor constructor) -> constructor `Set.member` constructors + _ -> False + +defaultType :: TypeGraph -> ResolvedTypeExpr -> DefaultType +defaultType graph = + foldTypeExpr + TypeExprAlgebra + { onText = DefaultText + , onInt = DefaultInt + , onBool = DefaultBool + , onNatural = DefaultNatural + , onTime = DefaultOther + , onJson = DefaultOther + , onOptional = const DefaultOptional + , onList = const DefaultList + , onMap = const DefaultMap + , onRef = referencedDefaultType graph + } + +referencedDefaultType :: TypeGraph -> MappedKey -> DefaultType +referencedDefaultType graph key = case Map.lookup key (tgDeclarations graph) of + Nothing -> DefaultOther + Just declaration -> + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ _ -> DefaultOther + , onEnum = DefaultEnum . Set.fromList . map weCtor + , onUnion = \_ _ -> DefaultOther + } + shape + , onOpaqueDecl = const DefaultOther + } + declaration + +data NullabilityFacts = NullabilityFacts + { nfTopNull :: !Bool + , nfBadOptional :: !Bool + } + +hasNonInjectiveOptional :: TypeGraph -> ResolvedTypeExpr -> Bool +hasNonInjectiveOptional graph = + nfBadOptional + . foldTypeExpr + TypeExprAlgebra + { onText = nonNull + , onInt = nonNull + , onBool = nonNull + , onNatural = nonNull + , onTime = nonNull + , onJson = nullable + , onOptional = \child -> NullabilityFacts True (nfTopNull child || nfBadOptional child) + , onList = nestedNonNull + , onMap = nestedNonNull + , onRef = \key -> if mappedRefIsOpaque graph key then nullable else nonNull + } + where + nonNull = NullabilityFacts False False + nullable = NullabilityFacts True False + nestedNonNull child = NullabilityFacts False (nfBadOptional child) + +mappedRefIsOpaque :: TypeGraph -> MappedKey -> Bool +mappedRefIsOpaque graph key = case Map.lookup key (tgDeclarations graph) of + Nothing -> False + Just declaration -> + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ _ -> False + , onOpaqueDecl = const True + } + declaration + +mappedRegisterInitialRules :: Spec -> TypeGraph -> [Diagnostic] +mappedRegisterInitialRules spec graph = + concatMap aggregateRules [aggregate | NAggregate aggregate <- specNodes spec] + where + aggregateRules aggregate = concatMap registerRule (aggRegs aggregate) + registerRule register = case Map.lookup (MappedKey (regType register)) (tgDeclarations graph) of + Nothing -> [] + Just declaration -> case regInitial register of + RegInitBare "initial" + | mappedInitial declaration == Nothing -> + [ mkErr (locLine (regLoc register)) MappedMissingInitialValue $ + "mapped register '" <> regName register <> "' requires declaration '" <> regType register <> "' to name an explicit initial value" + ] + | otherwise -> [] + _ -> + [ mkErr (locLine (regLoc register)) RegisterInitialOutOfScope $ + "mapped register '" <> regName register <> "' must use the bare initial token; the declaration-owned symbol is verified by GHC" + ] + mappedInitial = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \declaration _ -> sdInitial declaration + , onOpaqueDecl = odInitial + } + +{- | Mapped values support whole-value writes and event copies, but guards may +only operate on Keiki's curated scalar set. Nested access has no spelling in +the grammar, so it is unrepresentable rather than silently accepted. +-} +mappedGuardRules :: Spec -> TypeGraph -> [Diagnostic] +mappedGuardRules spec graph = + [ mkErr (locLine (tLoc transition)) MappedGuardUnsupported $ + "guard operand '" <> operand <> "' has non-symbolic type '" <> operandType <> "'; mapped values support whole-value copy, while guards are limited to Text, Int, Bool, and Time" + | NAggregate aggregate <- specNodes spec + , transition <- aggTransitions aggregate + , guardExpression <- maybe [] pure (tGuard transition) + , operand <- dedup (exprNames guardExpression) + , operandType <- maybeToList (guardOperandType aggregate transition operand) + , not (guardTypeSupported graph operandType) + ] + where + maybeToList = maybe [] pure + +guardOperandType :: Aggregate -> Transition -> Name -> Maybe Name +guardOperandType aggregate transition operand = + case [regType register | register <- aggRegs aggregate, regName register == operand] of + value : _ -> Just value + [] -> case [fieldType field | command <- aggCommands aggregate, cmdName command == tCommand transition, field <- cmdFields command, fieldName field == operand] of + value : _ -> value + [] -> Nothing + +guardTypeSupported :: TypeGraph -> Name -> Bool +guardTypeSupported graph typeName = + typeName `Set.member` Set.fromList ["Text", "Int", "Bool", "Time", "UTCTime"] + && Map.notMember (MappedKey typeName) (tgDeclarations graph) + +cabalPackageName :: Text -> Bool +cabalPackageName packageName = + not (null components) && all validComponent components + where + components = T.splitOn "-" packageName + validComponent component = + not (T.null component) + && T.all asciiAlphaNum component + && T.any asciiLetter component + +moduleNameSafe :: Text -> Bool +moduleNameSafe moduleName = + not (null components) && all constructorSafe components + where + components = T.splitOn "." moduleName + +qualifiedValueSafe :: Text -> Bool +qualifiedValueSafe qualified = case reverse (T.splitOn "." qualified) of + value : reversedModule -> + not (null reversedModule) + && lowerIdentifierSafe value + && all constructorSafe reversedModule + [] -> False + +lowerIdentifierSafe :: Text -> Bool +lowerIdentifierSafe name = case T.uncons name of + Just (first, rest) -> asciiLower first && T.all asciiAlphaNumOrUnderscore rest && name `Set.notMember` haskellKeywords + Nothing -> False + +asciiAlphaNum :: Char -> Bool +asciiAlphaNum c = asciiLetter c || (c >= '0' && c <= '9') + +asciiLetter :: Char -> Bool +asciiLetter c = asciiUpper c || asciiLower c + +asciiControl :: Char -> Bool +asciiControl c = ord c < 32 || ord c == 127 + +firstMatching :: (a -> Bool) -> [a] -> Maybe a +firstMatching predicate = \case + [] -> Nothing + value : rest + | predicate value -> Just value + | otherwise -> firstMatching predicate rest + +headOr :: a -> [a] -> a +headOr fallback = \case + [] -> fallback + value : _ -> value + {- | Reject names that would make the scaffolder emit illegal Haskell. The parser enforces the ASCII alphabet; this pass applies the category-specific uppercase/lowercase and keyword rules that require AST context. @@ -263,7 +821,7 @@ ++ concatMap (\field -> fieldNameRule "workqueue payload field" (wqfName field) (wqLoc workqueue)) (wqPayload workqueue) NPgmqDispatch dispatch -> pascalizedNodeName "dispatch" (pdName dispatch) (pdLoc dispatch) NReadModel readModel -> pascalizedNodeName "readmodel" (rmName readModel) (rmLoc readModel) - NWorkflow workflow -> constructorName "workflow name" (wfId workflow) (wfLoc workflow) + NWorkflow workflow -> constructorName "workflow name" (wfId workflow) (workflowNodeLoc workflow) NOperation _ -> [] aggregateNames aggregate = @@ -450,7 +1008,7 @@ nodeIdentity (NWorkqueue w) = ("workqueue", wqName w, wqLoc w) nodeIdentity (NPgmqDispatch d) = ("dispatch", pdName d, pdLoc d) nodeIdentity (NReadModel r) = ("readmodel", rmName r, rmLoc r) -nodeIdentity (NWorkflow w) = ("workflow", wfId w, wfLoc w) +nodeIdentity (NWorkflow w) = ("workflow", wfId w, workflowNodeLoc w) nodeIdentity (NOperation o) = ("operation", opName o, opLoc o) validateNode :: Spec -> Node -> [Diagnostic] @@ -505,7 +1063,7 @@ idField = case wfIdField w of Just field | field `notElem` inputFields -> - [ mkErr (locLine (wfLoc w)) WorkflowIdFieldUnresolved $ + [ mkErr (locLine (workflowNodeLoc w)) WorkflowIdFieldUnresolved $ "workflow '" <> wfId w <> "' derives its id from undeclared input field '" <> field <> "'" ] _ -> [] @@ -1230,6 +1788,7 @@ , statusMapTotality , evolutionRules , snapshotRules + , replayOnlyRules ] where states = Set.fromList (map stName (aggStates agg)) @@ -1439,9 +1998,26 @@ ] -- EP-2 evolution rules (single-spec; the diff path adds the cross-spec ones). - evolutionRules = versionUpcasterRule ++ deprecatedEmitRule ++ wireVersionRule - emittedNames = Set.fromList (concatMap tEmits (aggTransitions agg)) + evolutionRules = + versionUpcasterRule + ++ duplicateUpcasterSourceRule + ++ upcasterChainGapRule + ++ deprecatedEmitRule + ++ eventRetirementRules + ++ wireVersionRule + -- Only live transitions are the write path: a replay-only transition can + -- never fire forward, so its emits exist purely to invert stored events — + -- which is exactly where a deprecated event is allowed to remain + -- (plan 143; supersedes the guarded-but-inert retained-edge pattern). + liveEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmLive]) + replayEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmReplayOnly]) maxEventVersion = maximum (1 : map evVersion (aggEvents agg)) + upcasterSources = + Set.fromList + [ source + | event <- aggEvents agg + , Just (source, _) <- [evUpcastFrom event] + ] -- A non-initial event version must carry a contiguous upcaster (from v-1). versionUpcasterRule = @@ -1452,15 +2028,82 @@ , maybe True ((/= evVersion e - 1) . fst) (evUpcastFrom e) ] + -- A generated rung dispatches by event type, so different events may + -- deliberately share a source version when they changed in one release. + -- Duplicate declarations for one event cannot survive the parser's unique + -- event-name rule, so no additional duplicate-source diagnostic is needed. + duplicateUpcasterSourceRule = + [] + + -- Aggregate schema stamps are global, so every source version below the + -- current maximum needs a permanent rung regardless of which event owns it. + upcasterChainGapRule = + [ mkErr (locLine (aggLoc agg)) UpcasterChainGap $ + "no event declares 'upcast from v" + <> tInt missing + <> "'; stored payloads stamped v" + <> tInt missing + <> " can never reach v" + <> tInt maxEventVersion + <> " (GapInUpcasterChain at hydration). A rung, once shipped, must exist forever — restore the upcaster for v" + <> tInt missing + <> " (re-declare it on the event whose shape changed at v" + <> tInt (missing + 1) + <> ")" + | missing <- [1 .. maxEventVersion - 1] + , missing `Set.notMember` upcasterSources + ] + -- A deprecated event must have left the write path. deprecatedEmitRule = [ mkErr (locLine (evLoc e)) DeprecatedEventStillEmitted $ "deprecated event '" <> evName e <> "' is still emitted by a transition" | e <- aggEvents agg , evDeprecated e - , evName e `Set.member` emittedNames + , evName e `Set.member` liveEmittedNames ] + -- Retirement is a two-stage protocol. The pre-cutover marker keeps a live + -- emitter. The deprecated stage removes that live emitter but retains a + -- replay-only emitter until old payloads no longer need hydration. + eventRetirementRules = concatMap eventRetirementRule (aggEvents agg) + eventRetirementRule event + | evRetiring event = + [ mkErr (locLine (evLoc event)) EventRetirementInProgress $ + "retiring event '" <> evName event <> "' has no live emitting transition; keep it emitting while streams are terminalized or truncated, or cut over to 'deprecated event' with a replay-only emitting transition" + | evName event `Set.notMember` liveEmittedNames + ] + ++ [ Diagnostic + { line = locLine (evLoc event) + , severity = Warning + , code = EventRetirementInProgress + , message = + "event '" <> evName event <> "' is retiring: it stays fully live and replayable. Keep its live emitting transition until every affected stream is terminal or truncated; then flip it to 'deprecated event' and retain an equivalent replay-only emitting transition for as long as old payloads may be hydrated" + } + | evName event `Set.member` liveEmittedNames + ] + | evDeprecated event = + [ Diagnostic + { line = locLine (evLoc event) + , severity = Warning + , code = DeprecatedEventReplayHazard + , message = + "deprecated event '" <> evName event <> "' stays decodable but is not replayable: no replay-only transition emits it, so hydration of a live stream containing it fails with HydrationNoInvertingEdge. Restore an equivalent replay-only emitting transition, or terminalize/truncate every affected stream before deployment" + } + | any (not . stTerminal) (aggStates agg) + , evName event `Set.notMember` replayEmittedNames + ] + ++ [ Diagnostic + { line = locLine (evLoc event) + , severity = Warning + , code = EventRetirementInProgress + , message = + "deprecated event '" <> evName event <> "' is off the live write path and remains replayable through a replay-only transition; retain that transition until every stream containing the event is terminal, truncated, or passes the replay audit" + } + | evName event `Set.member` replayEmittedNames + ] + | otherwise = [] + -- The explicit `wire schemaVersion=` (if any) must equal the max event version. wireVersionRule = case aggWire agg of Just w @@ -1474,6 +2117,29 @@ } ] _ -> [] + + -- Plan 143: replay-only transition discipline. A replay-only transition + -- exists to invert stored events, so one that emits nothing is dead + -- weight (error); one whose (source, command) pair has no live sibling + -- means the command is fully retired at that state — legitimate, but the + -- fuller procedure is event retirement (docs/plans/139), so warn. + replayOnlyRules = concatMap replayOnlyRule (aggTransitions agg) + replayOnlyRule t + | tMode t /= TmReplayOnly = [] + | otherwise = + [ mkErr (locLine (tLoc t)) ReplayOnlyEmitsNothing $ + "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' emits no event; a replay-only transition exists to invert stored events and is dead weight without an emit" + | null (tEmits t) + ] + ++ [ Diagnostic + { line = locLine (tLoc t) + , severity = Warning + , code = ReplayOnlyCommandStillLive + , message = + "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' has no live sibling; command '" <> tCommand t <> "' is fully retired at state '" <> tSource t <> "' — if the intent is to retire its events too, follow the event-retirement procedure (docs/plans/139)" + } + | not (any (\sibling -> tMode sibling == TmLive && tSource sibling == tSource t && tCommand sibling == tCommand t) (aggTransitions agg)) + ] {- | The validator's re-derivation of the live 'Keiro.PGMQ.Runtime.queueRef' trio: physical queue, dead-letter queue, and diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,2462 +1,4206 @@ -{- | Test driver for keiro-dsl. EP-1 milestone 1 tests: the @parse . pretty@ -round-trip property over generated specs, and a unit test pinning the shape -of the canonical Reservation fixture. --} -module Main (main) where - -import Control.Exception (bracket) -import Control.Monad (filterM, forM_) -import Data.Either (isLeft) -import Data.List (partition, sort) -import Data.Text qualified as T -import Data.Text.IO qualified as TIO -import Keiro.Dsl.Diff (Change (..), ChangeKind (..), FamilyDiff (..), NodeFamily, diffSpecs, familyRegistry, isAdvisory, isBreaking) -import Keiro.Dsl.Grammar -import Keiro.Dsl.Harness (harnessFor, harnessReadModel, harnessRouter, harnessWorkflow) -import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest) -import Keiro.Dsl.Parser (parseSpec) -import Keiro.Dsl.PrettyPrint (renderSpec) -import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) -import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ScaffoldModule (..), defaultContext, firewallBreaches, genPrefixFor, holePrefixFor, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldRouter, scaffoldWorkqueue, windowSeconds) -import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) -import Keiro.Dsl.ScaffoldRun (Refusal (..), ScaffoldReport (..), StaleModule (..), executeScaffold, planScaffold, renderScaffoldReport, scaffoldModules) -import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) -import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, validateSpec) -import System.Directory (createDirectory, createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly) -import System.Environment (lookupEnv) -import System.FilePath (takeDirectory, ()) -import System.IO (hClose, openTempFile) -import Test.Hspec hiding (Spec) -import Test.QuickCheck - -main :: IO () -main = hspec $ do - describe "parse . pretty round-trip" $ - do - it "re-parses any generated spec to an equal AST (modulo source locations)" $ - checkCoverage $ - forAll genSpec $ \s -> - let families = map nodeTag (specNodes s) - roundTrip = parseSpec "" (renderSpec s) === Right s - in foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags - it "round-trips an aggregate with no states" $ - parseSpec "" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec - it "separates transition emit clauses from following nodes" $ do - spec <- parseInlineSpec "" crossFamilyBoundarySpec - case specNodes spec of - [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do - concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"] - aggStates second `shouldBe` [] - nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes)) - - describe "string literal integrity" $ do - it "parses an escaped emit-map value as exactly one row" $ do - let src = - T.unlines - [ "context svc" - , "" - , "emit e {" - , " contract c" - , " topic events" - , " source \"svc\"" - , " key thingId" - , " map status {" - , " \"a\\\" => Wat \\\"b\" => ThingAccepted" - , " _ => skip" - , " }" - , " messageId derive hole" - , " idempotencyKey derive hole" - , "}" - ] - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of - [row] -> do - emrValue row `shouldBe` "a\" => Wat \"b" - emrEvent row `shouldBe` "ThingAccepted" - rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows)) - it "rejects a raw newline inside a quoted string" $ do - let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"first\nsecond\"\n}\n" - parseSpec "" src `shouldSatisfy` leftContains "unescaped newline" - it "rejects an unknown escape sequence" $ do - let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"bad\\q\"\n}\n" - parseSpec "" src `shouldSatisfy` leftContains "unknown escape" - it "round-trips adversarial text through topics, emit maps, and quoted bindings" $ - property $ - forAll genAdversarialText $ \t -> - let spec = escapedSpec t - rendered = renderSpec spec - in counterexample (T.unpack rendered) (parseSpec "" rendered === Right spec) - - describe "partial status maps" $ do - it "suppresses totality only when the partial marker is present" $ do - partial <- parseInlineSpec "" (statusMapSpec " partial") - totalSpec <- parseInlineSpec "" (statusMapSpec "") - map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal] - map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal] - parseSpec "" (renderSpec partial) `shouldBe` Right partial - - describe "positioned parser diagnostics" $ do - it "rejects a duplicate goto at the second clause" $ do - err <- parseErrorOf "" duplicateGotoSpec - err `shouldSatisfy` T.isInfixOf "duplicate goto" - err `shouldSatisfy` T.isInfixOf ":10:" - it "rejects duplicate wire and projection blocks at their second occurrences" $ do - wireErr <- parseErrorOf "" duplicateWireSpec - wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block" - wireErr `shouldSatisfy` T.isInfixOf ":8:" - projectionErr <- parseErrorOf "" duplicateProjectionSpec - projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block" - projectionErr `shouldSatisfy` T.isInfixOf ":9:" - it "anchors a missing goto on the transition line" $ do - err <- parseErrorOf "" missingGotoSpec - err `shouldSatisfy` T.isInfixOf "missing a goto clause" - err `shouldSatisfy` T.isInfixOf ":8:" - it "stops before a misplaced dispatch-id and expects schedule at its start" $ do - let src = misplacedDispatchIdSpec - expectedPosition = - ":" - <> T.pack (show (lineNumberContaining "dispatch-id" src)) - <> ":5:" - err <- parseErrorOf "" src - err `shouldSatisfy` T.isInfixOf "schedule" - err `shouldSatisfy` T.isInfixOf expectedPosition - it "keeps a malformed register declaration's equals error" $ do - err <- parseErrorOf "" malformedRegisterSpec - err `shouldSatisfy` T.isInfixOf "expecting '='" - - describe "bounded decimal literals" $ do - forM_ decimalOverflowSpecs $ \(site, src) -> - it ("rejects overflow at " <> site) $ do - err <- parseErrorOf (" site <> ">") src - err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range") - it "accepts maxBound without changing its value" $ do - spec <- parseInlineSpec "" (wireDecimalSpec (T.pack (show (maxBound :: Int)))) - [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]] - `shouldBe` [maxBound] - - describe "identifier hygiene" $ do - it "reports constructor shape and Haskell keywords at their owning declarations" $ do - spec <- parseInlineSpec "" identifierHygieneSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentNotConstructorSafe, IdentHaskellKeyword]] - `shouldContain` [(IdentNotConstructorSafe, 3), (IdentHaskellKeyword, 7)] - it "rejects generated vertex constructors that collide with event constructors" $ do - spec <- parseInlineSpec "" vertexCollisionSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision] - `shouldBe` [(VertexCtorCollision, 3)] - it "rejects underscore-leading names whose title-casing cannot make a module segment" $ do - spec <- parseInlineSpec "" underscoreNodeSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe] - `shouldBe` [(IdentNotConstructorSafe, 3)] - it "rejects non-ASCII identifier characters in the parser" $ - parseSpec "" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected" - - describe "canonical reservation.keiro" $ - it "parses into the expected aggregate shape" $ do - input <- readTestText "test/fixtures/reservation.keiro" - case parseSpec "test/fixtures/reservation.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specContext spec `shouldBe` "hospital-capacity" - length (specIds spec) `shouldBe` 3 - length (specEnums spec) `shouldBe` 3 - length (specRules spec) `shouldBe` 1 - case specNodes spec of - [NAggregate a] -> do - aggName a `shouldBe` "Reservation" - length (aggStates a) `shouldBe` 6 - length (aggCommands a) `shouldBe` 2 - length (aggEvents a) `shouldBe` 2 - length (aggTransitions a) `shouldBe` 2 - map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True] - other -> expectationFailure ("expected one aggregate node, got " <> show (length other)) - - describe "validator" $ do - it "accepts the canonical reservation.keiro" $ do - codes <- errorCodesOf "test/fixtures/reservation.keiro" - codes `shouldBe` [] - it "rejects a missing status-map as StatusMapNotTotal" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro" - codes `shouldContain` [StatusMapNotTotal] - it "rejects an undeclared command as UndeclaredCommand" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro" - codes `shouldContain` [UndeclaredCommand] - it "rejects a wall-clock guard atom as ClockSampled" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro" - codes `shouldContain` [ClockSampled] - it "accepts a v2 event with a contiguous upcaster hole" $ do - codes <- errorCodesOf "test/fixtures/reservation-v2.keiro" - codes `shouldBe` [] - it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro" - codes `shouldContain` [EvtVersionMissingUpcaster] - it "requires exact, unique status-map event keys" $ do - dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro" - mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal] - duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro" - duplicate `shouldContain` [StatusMapDuplicateKey] - it "rejects duplicate spec and aggregate names" $ do - codes <- errorCodesOf "test/fixtures/duplicate-names.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [ DuplicateNodeName - , DuplicateEnumCtor - , DuplicateEnumWire - , DuplicateIdPrefix - , DuplicateCommandName - , DuplicateEventName - ] - it "rejects aggregate-local references that do not resolve" $ do - codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro" - codes `shouldContain` [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister] - it "anchors UnreachableState on the state row" $ do - let src = - T.unlines - [ "context repro" - , "" - , "aggregate Thing" - , " regs" - , " states" - , " Initial" - , " Unreachable" - ] - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> - [line d | d <- validateSpec spec, code d == UnreachableState] - `shouldBe` [7] - - describe "evolution parsing" $ - it "parses event version and upcaster from reservation-v2.keiro" $ do - input <- readTestText "test/fixtures/reservation-v2.keiro" - case parseSpec "test/fixtures/reservation-v2.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of - (e : _) -> do - evVersion e `shouldBe` 2 - evUpcastFrom e `shouldBe` Just (1, Hole) - [] -> expectationFailure "TransferReservationCreated not found" - - describe "aggregate snapshots (EP-109)" $ do - it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do - spec <- specOf "test/fixtures/reservation-snapshot.keiro" - errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` [] - parseSpec "" (renderSpec spec) `shouldBe` Right spec - case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc" noLoc) - aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates)) - it "rejects disabled intervals and invalid codec fixtures" $ do - source <- readTestText "test/fixtures/reservation-snapshot.keiro" - interval <- parseInlineSpec "" (T.replace "snapshot every 100" "snapshot every 0" source) - map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid] - version <- parseInlineSpec "" (T.replace "state-codec version=1" "state-codec version=0" source) - map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid] - emptyHash <- parseInlineSpec "" (T.replace "shape-hash=\"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\"" "shape-hash=\"\"" source) - map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid] - it "conditionally lowers JSON instances and the live defaultStateCodec" $ do - snapshot <- specOf "test/fixtures/reservation-snapshot.keiro" - ordinary <- specOf "test/fixtures/reservation.keiro" - case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of - ([snapshotAggregate], [ordinaryAggregate]) -> do - let snapshotModules = scaffoldAggregate (defaultContext (specContext snapshot)) snapshot snapshotAggregate - ordinaryModules = scaffoldAggregate (defaultContext (specContext ordinary)) ordinary ordinaryAggregate - snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules - snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules - ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules - ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules - snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)" - snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100" - snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (defaultStateCodec 1)" - snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\")" - ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass" - ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never" - ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing" - ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\"" - firewallBreaches snapshotModules `shouldBe` [] - _ -> expectationFailure "expected one aggregate in each snapshot test spec" - - describe "process/timer (EP-3)" $ do - it "parses the hospital-surge process + nested timer" $ do - input <- readTestText "test/fixtures/hospital-surge.keiro" - case parseSpec "test/fixtures/hospital-surge.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [p | NProcess p <- specNodes spec] of - (p : _) -> do - procId p `shouldBe` "HospitalSurge" - procName p `shouldBe` "hospital-surge" - procRejected p `shouldBe` PolHalt - procPoison p `shouldBe` PolHalt - sagaCategory (procSaga p) `shouldBe` "hospitalSurge" - tmName (procTimer p) `shouldBe` "surgeFollowUp" - onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired - onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry - tmMaxAttempts (procTimer p) `shouldBe` 5 - [] -> expectationFailure "no process node parsed" - it "round-trips the hospital-surge spec through parse . pretty" $ do - input <- readTestText "test/fixtures/hospital-surge.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge.keiro" - codes `shouldBe` [] - it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - mapM_ - (\categoryName -> processErrorCodes (\process -> process{procSaga = (procSaga process){sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal]) - ["", "$all", "hospital-surge", "hospital surge", "wf:surge"] - source <- readTestText "test/fixtures/hospital-surge.keiro" - parseSpec "" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source) - `shouldSatisfy` isLeft - it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" - codes `shouldContain` [ProcessFireAtNotInjected] - it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" - length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1 - it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro" - codes `shouldContain` [ProcessDispatchIdSupplied] - it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro" - codes `shouldContain` [ProcessUnresolvedRef] - it "rejects unresolved process commands, projections, schedules, and advance ids" $ do - codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro" - length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5 - codes `shouldContain` [ProcessDispatchIdSupplied] - - describe "router (EP-108)" $ do - it "parses the incident-paging router shape" $ do - input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" - case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [router | NRouter router <- specNodes spec] of - [router] -> do - rtId router `shouldBe` "PagingRouter" - rtName router `shouldBe` "jitsurei-paging" - corrField (rtKey router) `shouldBe` "incidentId" - rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall" - rvRow (rtResolve router) `shouldBe` ["responderId"] - rdCommand (rtDispatch router) `shouldBe` "SendPage" - rtRejected router `shouldBe` PolDeadLetter - rtPoison router `shouldBe` PolHalt - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "round-trips the incident-paging spec through parse . pretty" $ do - input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the incident-paging router with warnings only" $ do - codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro" - codes `shouldBe` [] - diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro" - diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy] - it "rejects unresolved targets, keys, commands, and binding scopes" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - routerErrorCodes (\router -> router{rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef] - routerErrorCodes (\router -> router{rtKey = (rtKey router){corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown] - routerErrorCodes (\router -> router{rtDispatch = (rtDispatch router){rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown] - routerErrorCodes - ( \router -> - let dispatch = rtDispatch router - in router{rtDispatch = dispatch{rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}} - ) - spec - `shouldContain` [RouterBindingUnscoped] - it "rejects unresolved read models and contradictory rejection policies" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let withoutReadModel = removeReadModel "service_oncall" spec - errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef] - routerErrorCodes - ( \router -> - let dispatch = rtDispatch router - disposition = rdDisposition dispatch - in router - { rtRejected = PolHalt - , rtDispatch = dispatch{rdDisposition = disposition{onFailed = DDeadLetter "page rejected"}} - } - ) - spec - `shouldContain` [PolicyContradiction] - it "rejects on-ambiguous Fired for process timers" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - let changed = - spec - { specNodes = - [ case node of - NProcess process -> - let timer = procTimer process - fire = tmFire timer - disposition = fireDisposition fire - in NProcess process{procTimer = timer{tmFire = fire{fireDisposition = disposition{onAmbiguous = OFired}}}} - _ -> node - | node <- specNodes spec - ] - } - errorCodes changed `shouldContain` [AmbiguousMarkedBenign] - it "requires explicit policy and ambiguity clauses in the grammar" $ do - source <- readTestText "test/fixtures/hospital-surge.keiro" - parseSpec "" (T.replace " poison => halt\n" "" source) `shouldSatisfy` isLeft - parseSpec "" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft - it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> do - let ctx = defaultContext (specContext spec) - modules = scaffoldRouter ctx router - generated = [m | m <- modules, kind m == Generated] - holes = [m | m <- modules, kind m == HoleStub] - firewallBreaches generated `shouldBe` [] - case (generated, holes) of - ([generatedModule], [holeModule]) -> do - moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter" - moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities" - moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" - _ -> expectationFailure "expected one generated router module and one router hole module" - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "requires a caller callback for non-halting poison policies" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> do - let ctx = defaultContext (specContext spec) - generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated] - mapM_ - ( \(choice, constructor) -> case generatedFor choice of - [generatedModule] -> do - generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg" - generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback") - _ -> expectationFailure "expected one generated router module" - ) - [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")] - case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of - [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip" - _ -> expectationFailure "expected one generated router module" - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "emits router harness facts that pin policy and target-keyed identity" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> case harnessRouter (defaultContext (specContext spec)) router of - [facts] -> do - moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")" - moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence" - modules -> expectationFailure ("expected one router harness, got " <> show (length modules)) - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "rejects invalid timer ceilings and target field bindings" $ do - codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved] - it "accepts resolved process projection references" $ do - codes <- errorCodesOf "test/fixtures/surge-service.keiro" - codes `shouldBe` [] - it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do - mods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - let gens = [m | m <- mods, kind m == Generated] - holes = [m | m <- mods, kind m == HoleStub] - length holes `shouldBe` 1 - firewallBreaches gens `shouldBe` [] - case gens of - [generatedModule] -> do - -- the worker uses the spec's ceiling, never the dangerous default - moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\"" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)" - case holes of - [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory" - _ -> expectationFailure "expected one process hole module" - _ -> expectationFailure "expected one generated process module" - it "process scaffold is deterministic" $ do - a <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - b <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - map moduleText a `shouldBe` map moduleText b - - describe "contract (EP-4)" $ do - it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do - input <- readTestText "test/fixtures/contract.keiro" - case parseSpec "test/fixtures/contract.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [c | NContract c <- specNodes spec] of - (c : _) -> do - ctrName c `shouldBe` "emergency" - ctrDiscriminator c `shouldBe` "messageType" - map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"] - map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"] - [] -> expectationFailure "no contract node parsed" - it "round-trips the contract spec through parse . pretty" $ do - input <- readTestText "test/fixtures/contract.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "round-trips the intake (inbox) spec through parse . pretty" $ do - input <- readTestText "test/fixtures/intake.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the intake spec (complete disposition, no inversions)" $ do - codes <- errorCodesOf "test/fixtures/intake.keiro" - codes `shouldBe` [] - it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do - spec <- specOf "test/fixtures/intake.keiro" - ordinary <- specOf "test/fixtures/intake-decode.keiro" - case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of - ([intake], [defaultIntake]) -> do - inkPersist intake `shouldBe` InkPersistDedupeOnly - inkPersist defaultIntake `shouldBe` InkPersistFull - renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only" - renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist =" - let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake) - inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly" - (intakes, defaultIntakes) -> - expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes)) - it "rejects duplicate => retry (inversion 1)" $ do - codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro" - codes `shouldContain` [DispositionDuplicateRetry] - it "rejects previouslyFailed => retry (inversion 2)" $ do - codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro" - codes `shouldContain` [DispositionPreviouslyFailedRetry] - it "rejects an incomplete disposition table" $ do - codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro" - codes `shouldContain` [DispositionIncomplete] - it "rejects a shadowing duplicate intake disposition row" $ do - codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro" - codes `shouldContain` [DispositionDuplicateOutcome] - it "rejects intake events declared on another topic" $ do - codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro" - codes `shouldContain` [TopicAffinityMismatch] - it "round-trips the emit/publisher spec through parse . pretty" $ do - input <- readTestText "test/fixtures/emit.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do - codes <- errorCodesOf "test/fixtures/emit.keiro" - codes `shouldBe` [] - it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do - codes <- errorCodesOf "test/fixtures/emit-noskip.keiro" - codes `shouldContain` [EmitSkipMissing] - it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do - codes <- errorCodesOf "test/fixtures/emit-badevent.keiro" - codes `shouldContain` [EmitUnresolvedContract] - it "rejects emit events declared on another topic" $ do - codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro" - codes `shouldContain` [TopicAffinityMismatch] - - describe "pgmq workqueue/dispatch (EP-5)" $ do - it "round-trips the reservation-work spec through parse . pretty" $ do - input <- readTestText "test/fixtures/reservation-work.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the reservation-work spec (physical matches, no inversions)" $ do - codes <- errorCodesOf "test/fixtures/reservation-work.keiro" - codes `shouldBe` [] - it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro" - codes `shouldContain` [WqPhysicalDivergence] - it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro" - codes `shouldContain` [WqStoreFailureNotRetry] - it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro" - codes `shouldContain` [WqDecodeFailureNotDeadLetter] - it "requires complete, unique workqueue disposition rows" $ do - incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro" - incomplete `shouldContain` [WqDispositionIncomplete] - duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro" - let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome] - map line duplicateDiagnostics `shouldBe` [17] - it "checks the captured queueRef dlq and table fixtures" $ do - dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro" - dlqCodes `shouldContain` [WqDlqDivergence] - tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro" - tableCodes `shouldContain` [WqTableDivergence] - it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do - upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro" - upper `shouldBe` [] - hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro" - hashed `shouldBe` [] - derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments" - `shouldBe` ( "hospital_capacity_reservat_757040df00976c33" - , "hospital_capacity_reservat_757040df00976c33_dlq" - , "pgmq.q_hospital_capacity_reservat_757040df00976c33" - ) - it "resolves dispatch dedup queues and payload wire fields" $ do - ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro" - ghost `shouldContain` [DispatchDedupQueueUnresolved] - field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro" - field `shouldContain` [DispatchDedupFieldUnresolved] - it "requires a resolvable group key exactly when ordering is FIFO" $ do - noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro" - noKey `shouldContain` [WqGroupKeyMissing] - unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro" - unordered `shouldContain` [WqGroupKeyWithoutFifo] - source <- readTestText "test/fixtures/reservation-work.keiro" - unresolved <- parseInlineSpec "" (T.replace "group key from reservationId" "group key from missingId" source) - map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved] - it "warns on unlogged storage and rejects empty partition settings" $ do - warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro" - warningCodes `shouldContain` [WqUnloggedDurability] - partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro" - partitionCodes `shouldContain` [WqPartitionSpecEmpty] - it "lowers ordering, provisioning, and raw group-key projection" $ do - spec <- specOf "test/fixtures/reservation-work.keiro" - case [workqueue | NWorkqueue workqueue <- specNodes spec] of - workqueue : _ -> do - let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue - queue = generatedTextEndingIn "Queue.hs" modules - policy = generatedTextEndingIn "QueuePolicy.hs" modules - queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId" - policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput" - policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)" - firewallBreaches modules `shouldBe` [] - [] -> expectationFailure "reservation-work fixture has no workqueue" - - describe "readmodel (EP-107)" $ do - it "parses and round-trips first-class read models" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - [subscriptionModel, inlineModel] -> do - rmName subscriptionModel `shouldBe` "transfer_decisions" - rmColumns subscriptionModel - `shouldBe` [ RmColumn "reservation_id" "text" True - , RmColumn "hospital_id" "text" True - , RmColumn "status" "text" True - , RmColumn "decided_at" "timestamptz" False - ] - rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation") - rmFeed subscriptionModel `shouldBe` RmSubscription - rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub" - rmName inlineModel `shouldBe` "subscriptions" - rmScope inlineModel `shouldBe` Nothing - rmFeed inlineModel `shouldBe` RmInline - nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes)) - parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts an aggregate projection without a consistency clause" $ do - spec <- parseInlineSpec "" projectionWithoutConsistencySpec - case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of - [projection] -> projConsistency projection `shouldBe` Nothing - projections -> expectationFailure ("expected one projection, got " <> show (length projections)) - it "pins the canonical UTF-8 shape digest and runtime identities" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - (subscriptionModel : inlineModel : _) -> do - canonicalShape subscriptionModel - `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null" - deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6" - deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738" - registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions" - subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub" - subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub" - nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) - it "accepts the positive readmodel fixture with all references resolved" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - validateSpec spec `shouldBe` [] - it "rejects shape drift and unknown SQL column types" $ do - codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro" - codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType] - it "rejects Strong on inline and standalone projections" $ do - inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro" - inlineCodes `shouldContain` [RmStrongInlineOnly] - standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro" - let diagnostics = validateSpec standalone - map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode] - [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode] - `shouldBe` [Warning] - it "rejects scope without Strong and an unreferenced inline feed" $ do - scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro" - scopeCodes `shouldContain` [RmScopeWithoutStrong] - inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro" - inlineCodes `shouldContain` [RmInlineFeedUnreferenced] - it "rejects projection consistency conflicts" $ do - codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro" - codes `shouldContain` [RmConsistencyConflict] - it "resolves query read models and validates query consistency" $ do - codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro" - codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid] - it "resolves dispatch read models and declared dedup columns" $ do - codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro" - codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown] - it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - let ctx = defaultContext (specContext spec) - readModels = [readModel | NReadModel readModel <- specNodes spec] - modules = concatMap (scaffoldReadModel ctx) readModels - transfer = generatedTextEndingIn "Transfer_decisions/ReadModel.hs" modules - inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules - transferHoles = [moduleText m | m <- modules, "Transfer_decisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)] - length modules `shouldBe` 6 - length [m | m <- modules, kind m == Generated] `shouldBe` 4 - length [m | m <- modules, kind m == HoleStub] `shouldBe` 2 - firewallBreaches modules `shouldBe` [] - transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions" - transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]" - transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\"" - transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection" - inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []" - inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection" - transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()") - it "threads qualified table and column guidance into aggregate projection holes" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> do - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate - holes = [moduleText m | m <- modules, kind m == HoleStub] - projection = generatedTextEndingIn "Projection.hs" modules - holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable") - holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"") - projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable" - aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates)) - it "emits runtime-free derivation facts for each read model" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - (subscriptionModel : _) -> do - let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel - harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules - length modules `shouldBe` 1 - firewallBreaches modules `shouldBe` [] - harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", \"fnv1a:3717f6d9e3c44bd6\")" - harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", \"CategoryHead reservation\")" - harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts" - nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) - - describe "workflow/operation (EP-6)" $ do - it "round-trips the workflow spec through parse . pretty" $ do - input <- readTestText "test/fixtures/workflow.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the workflow spec (await<->signal matches, run resolves)" $ do - codes <- errorCodesOf "test/fixtures/workflow.keiro" - codes `shouldBe` [] - it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do - codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro" - codes `shouldContain` [AwaitSignalMismatch] - it "rejects duplicate workflow labels" $ do - codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro" - codes `shouldContain` [WorkflowDuplicateLabel] - it "rejects unresolved workflow id and sleep fields" $ do - codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro" - codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved] - it "validates rule domains, totality, case constructors, and bodies" $ do - unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro" - unresolved `shouldBe` [RuleDomainUnresolved] - codes <- errorCodesOf "test/fixtures/rule-not-total.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope] - it "rejects unresolved command operation references" $ do - codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro" - codes `shouldContain` [OperationUnresolvedRef] - it "rejects a signal value type that differs from its await" $ do - codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro" - codes `shouldContain` [AwaitSignalValueMismatch] - it "round-trips guarded patches and terminal continueAsNew" $ do - input <- readTestText "test/fixtures/workflow-evolution.keiro" - case parseSpec "workflow-evolution" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec - errorCodes spec `shouldBe` [] - it "rejects duplicate patch ids anywhere in the workflow body" $ do - codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro" - codes `shouldBe` [WorkflowPatchDuplicate] - it "rejects non-terminal and nested continueAsNew" $ do - codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro" - codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal] - it "rejects a colon in a patch id with a workflow diagnostic" $ do - codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro" - codes `shouldBe` [WorkflowPatchIdInvalid] - it "lowers patch facts and live runtime declarations" $ do - spec <- specOf "test/fixtures/workflow-evolution.keiro" - case [workflow | NWorkflow workflow <- specNodes spec] of - [workflow] -> do - let modules = harnessWorkflow (defaultContext (specContext spec)) workflow - facts = generatedTextEndingIn "WorkflowFacts.hs" modules - runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules - facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)" - facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed" - facts `shouldSatisfy` T.isInfixOf "(\"patches\", \"fraud-check-v2\")" - runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]" - runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}" - workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows)) - - describe "diff (evolution classification)" $ do - it "covers every node family exactly once and explains exclusions" $ do - sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily]) - [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` [] - it "classifies a field added without a version bump as BREAKING" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro" - any isBreaking cs `shouldBe` True - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldAddedWithoutBump] - it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" - any isBreaking cs `shouldBe` False - [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject) - it "reports no breaking change when the spec is unchanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro" - any isBreaking cs `shouldBe` False - it "classifies a direct event field type change as EvtFieldTypeChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldTypeChanged] - it "resolves fields(Command) before comparing event field types" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldTypeChanged] - it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldRemovedSameVersion] - it "uses EvtVersionDecreased for a version decrease" $ do - cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtVersionDecreased] - it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtVersionMissingUpcaster] - it "classifies an enum constructor removal as EnumCtorRemoved" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EnumCtorRemoved] - it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just EnumWireSpellingChanged] - it "classifies an enum constructor addition as additive" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs] `shouldContain` ["BlackTag"] - it "classifies an effective wire convention change as WireSpecChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WireSpecChanged] - it "keeps deprecation additive and reports un-deprecation as EventUndeprecated" $ do - deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro" - any isBreaking deprecated `shouldBe` False - restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro" - any isAdvisory restored `shouldBe` True - [ckCode k | Advisory k <- restored] `shouldContain` [Just EventUndeprecated] - it "classifies a removed contract event as ContractEventRemoved" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just ContractEventRemoved] - it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do - changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro" - [ckCode k | Breaking k <- changed] `shouldContain` [Just ContractFieldChanged] - added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro" - [ckCode k | Breaking k <- added] `shouldContain` [Just ContractFieldChanged] - it "reports a field addition with a contract version bump as an advisory" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [Just ContractSchemaVersionBumped] - it "classifies a contract schema version decrease separately" $ do - cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just ContractSchemaVersionDecreased] - it "classifies contract topic and discriminator changes separately" $ do - topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro" - [ckCode k | Breaking k <- topic] `shouldContain` [Just ContractTopicChanged] - discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro" - [ckCode k | Breaking k <- discriminator] `shouldContain` [Just ContractDiscriminatorChanged] - it "classifies a new contract event as additive" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"] - it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do - wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro" - [ckCode k | Breaking k <- wire] `shouldContain` [Just WqPayloadFieldChanged] - fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro" - [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [Just WqPayloadFieldChanged] - required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro" - [ckCode k | Breaking k <- required] `shouldContain` [Just WqPayloadFieldChanged] - it "classifies a new optional workqueue payload field as additive" $ do - cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs] `shouldContain` ["note"] - it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WqOrderingChanged] - [ckDetail k | Breaking k <- cs, ckCode k == Just WqOrderingChanged] - `shouldSatisfy` any (T.isInfixOf "delivery-order contract") - it "classifies workqueue provision changes as operational migrations" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WqProvisionChanged] - [ckDetail k | Breaking k <- cs, ckCode k == Just WqProvisionChanged] - `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally") - it "classifies workqueue group-key changes as breaking repartitioning" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WqGroupKeyChanged] - [ckDetail k | Breaking k <- cs, ckCode k == Just WqGroupKeyChanged] - `shouldSatisfy` any (T.isInfixOf "re-partitioned") - it "classifies a process input type change as ProcessInputChanged" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just ProcessInputChanged] - it "classifies workflow input and output changes as WorkflowShapeChanged" $ do - input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro" - [ckCode k | Breaking k <- input] `shouldContain` [Just WorkflowShapeChanged] - output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro" - [ckCode k | Breaking k <- output] `shouldContain` [Just WorkflowShapeChanged] - it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do - relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro" - [ckCode k | Breaking k <- relabeled] `shouldContain` [Just WorkflowBodyChanged] - appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro" - [ckCode k | Breaking k <- appended] `shouldContain` [Just WorkflowBodyChanged] - [ckDetail k | Breaking k <- appended, ckCode k == Just WorkflowBodyChanged] - `shouldSatisfy` any (T.isInfixOf "new patch guard") - it "classifies a body addition wholly guarded by a new patch as additive" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"] - [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"] - it "classifies removing an existing patch as breaking" $ do - cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WorkflowPatchRemoved] - [ckDetail k | Breaking k <- cs, ckCode k == Just WorkflowPatchRemoved] - `shouldSatisfy` any (T.isInfixOf "cannot prove") - it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do - appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro" - any isBreaking appended `shouldBe` False - [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"] - changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro" - [ckCode k | Breaking k <- changed] `shouldContain` [Just WorkflowContinueSeedChanged] - [ckDetail k | Breaking k <- changed, ckCode k == Just WorkflowContinueSeedChanged] - `shouldSatisfy` any (T.isInfixOf "restoreSeed") - it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just WorkflowStableNameChanged] - it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just DerivedIdentityChanged] - it "classifies an id prefix change as IdPrefixChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just IdPrefixChanged] - it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do - policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro" - [ckCode k | Breaking k <- policy] `shouldContain` [Just DedupeIdentityChanged] - key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro" - [ckCode k | Breaking k <- key] `shouldContain` [Just DedupeIdentityChanged] - it "reports intake decode-posture changes as warnings" $ do - cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [Just DecodePostureChanged] - [ckCode k | Advisory k <- cs] `shouldContain` [Just IntakePersistenceChanged] - it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do - processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro" - [ckCode k | Breaking k <- processName] `shouldContain` [Just DerivedIdentityChanged] - timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro" - [ckCode k | Breaking k <- timerId] `shouldContain` [Just DerivedIdentityChanged] - base <- specOf "test/fixtures/hospital-surge.keiro" - let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process{procSaga = (procSaga process){sagaCategory = "hospitalSurgeV2"}}) base) - [ckCode k | Breaking k <- categoryChange] `shouldContain` [Just DerivedIdentityChanged] - it "classifies router stable names, keys, and targets as identity-bearing" $ do - base <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtName = "paging-v2"}) base) - keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtKey = (rtKey router){corrVia = "otherIdText"}}) base) - target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtTarget = "OtherPage"}) base) - [ckCode k | Breaking k <- stableName] `shouldContain` [Just RouterStableNameChanged] - [ckCode k | Breaking k <- keyDerivation] `shouldContain` [Just DerivedIdentityChanged] - [ckCode k | Breaking k <- target] `shouldContain` [Just DerivedIdentityChanged] - it "reports a timer window change as a warning" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [Just TimerWindowChanged] - it "reports emit-map changes as warnings and derive changes as breaking" $ do - mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro" - any isBreaking mapping `shouldBe` False - [ckCode k | Advisory k <- mapping] `shouldContain` [Just EmitMappingChanged] - derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro" - [ckCode k | Breaking k <- derive] `shouldContain` [Just DerivedIdentityChanged] - it "classifies publisher outbox identity and ordering independently" $ do - outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro" - [ckCode k | Breaking k <- outbox] `shouldContain` [Just DerivedIdentityChanged] - ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro" - any isBreaking ordering `shouldBe` False - [ckCode k | Advisory k <- ordering] `shouldContain` [Just PublisherPolicyChanged] - it "classifies workqueue names as QueueIdentityChanged" $ do - cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [Just QueueIdentityChanged] - it "classifies pgmq dispatch dedupe and retargeting independently" $ do - dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro" - [ckCode k | Breaking k <- dedupe] `shouldContain` [Just DedupeIdentityChanged] - retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro" - any isBreaking retarget `shouldBe` False - [ckCode k | Advisory k <- retarget] `shouldContain` [Just DispatchRetargeted] - it "reports aggregate projection changes as warnings" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [Just ProjectionChanged] - it "classifies read-model version and unversioned shape changes" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmVersion = 2}) base - changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base - bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel){rmVersion = 2}) base - decreased = diffSpecs versionTwo base - unversioned = diffSpecs base changedShape - bumped = diffSpecs base bumpedShape - [ckCode k | Breaking k <- decreased] `shouldContain` [Just ReadModelVersionDecreased] - [ckCode k | Breaking k <- unversioned] `shouldContain` [Just ReadModelShapeChangedWithoutBump] - any isBreaking bumped `shouldBe` False - [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"] - it "classifies read-model registry, table, subscription, and removal identities" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmTable = "transfer_decisions_v2"}) base - subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmSubscription = Just "transfer-decisions-v2"}) base - renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmName = "reservation_decisions"}) base - removed = removeReadModel "transfer_decisions" base - mapM_ - (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [Just DerivedIdentityChanged]) - [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed] - it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmFeed = RmInline}) base - consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) base - entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmScope = Just RmEntireLog}) base - [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [Just ReadModelFeedChanged] - [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [Just ReadModelConsistencyWeakened] - [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [Just ReadModelConsistencyWeakened] - it "classifies Eventual to Strong read-model consistency as additive" $ do - strong <- specOf "test/fixtures/readmodel-runtime.keiro" - let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) strong - changes = diffSpecs eventual strong - any isBreaking changes `shouldBe` False - [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"] - - describe "module placement (M1)" $ do - it "GeneratedPrefix is today's namespace (Generated.., holes at .)" $ do - let ctx = defaultContext "hospital-capacity" - genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation" - holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation" - it "module-root prefixes both layers" $ do - let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"} - genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation" - holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" - it "CollocatedLeaf places the generated layer under the domain leaf" $ do - let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf} - genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated" - holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" - it "parses and preserves the module/layout clauses through parse . pretty" $ do - let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n regs\n states Open\n" - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specModuleRoot spec `shouldBe` Just "Acme.Services" - specLayout spec `shouldBe` Just CollocatedLeaf - parseSpec "" (renderSpec spec) `shouldBe` Right spec - it "a spec without the clauses leaves placement at the default" $ do - input <- readTestText "test/fixtures/reservation.keiro" - case parseSpec "test/fixtures/reservation.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specModuleRoot spec `shouldBe` Nothing - specLayout spec `shouldBe` Nothing - - describe "manifest (M2)" $ do - it "lists exactly the modules the scaffolder produced" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - spec <- specOf "test/fixtures/reservation.keiro" - let manifest = renderManifest "reservation.keiro" mods spec - expectedNames = sort (map (moduleNameOf . modulePath) mods) - -- every produced module name appears in the manifest… - mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames - -- …and the module list is exactly the scaffolder's output set. - expectedNames - `shouldBe` sort - [ "Generated.HospitalCapacity.Reservation.Codec" - , "Generated.HospitalCapacity.Reservation.Domain" - , "Generated.HospitalCapacity.Reservation.EventStream" - , "Generated.HospitalCapacity.Reservation.Harness" - , "Generated.HospitalCapacity.Reservation.Projection" - , "HospitalCapacity.Reservation.Holes" - ] - it "derives the dependency set from the node kinds present (aggregate)" $ do - spec <- specOf "test/fixtures/reservation.keiro" - manifestDependencies spec `shouldBe` ["aeson", "base", "keiki", "keiro", "text"] - it "derives the process dependency set, including worker-policy runtime imports" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - let dependencies = manifestDependencies spec - mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"] - it "uses the registered shibuya-core package name for router scaffolds" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let dependencies = manifestDependencies spec - mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"] - dependencies `shouldNotContain` ["shibuya"] - - describe "new skeletons (M5)" $ do - it "every skeleton parses and validates with zero error diagnostics" $ - mapM_ assertSkeletonValid skeletonKinds - it "every skeleton passes the scaffold refusal gates" $ - mapM_ assertSkeletonScaffoldable skeletonKinds - it "fresh skeleton scaffolds match the committed compiling modules" $ - mapM_ (uncurry assertSkeletonMatchesCommitted) skeletonModuleRoots - it "rejects an unknown kind with a helpful message" $ - case skeletonFor "bogus" of - Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True - Right _ -> expectationFailure "expected an error for an unknown kind" - - describe "firewall self-check (M3)" $ do - it "flags a forbidden operator in a Generated module" $ do - let m = ScaffoldModule{modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"} - firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)] - it "ignores forbidden operators in a HoleStub module (holes own them)" $ do - let m = ScaffoldModule{modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"} - firewallBreaches [m] `shouldBe` [] - it "matches `lit` as a word, not a substring of quality/split" $ do - let clean = ScaffoldModule{modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"} - dirty = ScaffoldModule{modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"} - firewallBreaches [clean] `shouldBe` [] - firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)] - it "skips strings and comments and maximal-munches symbolic tokens" $ do - let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b" - dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d" - firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)] - firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)] - it "guards keiki imports while allowing the generated Core allowlist" $ do - let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder" - restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)" - allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)" - firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)] - firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)] - firewallBreaches [allowed] `shouldBe` [] - it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do - aggMods <- scaffoldFixture "test/fixtures/reservation.keiro" - procMods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - firewallBreaches (aggMods <> procMods) `shouldBe` [] - - describe "scaffold gates" $ do - it "refuses duplicate and case-folded module paths with both origins" $ do - spec <- specOf "test/fixtures/reservation.keiro" - case [aggregate | NAggregate aggregate <- specNodes spec] of - aggregate : _ -> do - let duplicate = spec{specNodes = [NAggregate aggregate, NAggregate aggregate]} - caseVariant = spec{specNodes = [NAggregate aggregate, NAggregate aggregate{aggName = T.toUpper (aggName aggregate)}]} - planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins - planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins - [] -> expectationFailure "reservation fixture has no aggregate" - it "refuses a bannerless Generated target without changing its bytes" $ - withTempDirectory "keiro-dsl-banner" $ \out -> do - spec <- specOf "test/fixtures/reservation.keiro" - let ctx = defaultContext (specContext spec) - case planScaffold ctx spec of - Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals) - Right modules -> case [m | m <- modules, kind m == Generated] of - generated : _ -> do - let target = out modulePath generated - createDirectoryIfMissing True (takeDirectory target) - TIO.writeFile target "hand owned\n" - result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules - result `shouldSatisfy` isMissingBannerRefusal - TIO.readFile target `shouldReturn` "hand owned\n" - forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules - forced `shouldSatisfy` isSuccessfulScaffold - TIO.readFile target `shouldReturn` moduleText generated - [] -> expectationFailure "reservation scaffold has no Generated module" - it "reports renamed-node modules as stale without deleting them" $ - withTempDirectory "keiro-dsl-stale-rename" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec - let renamed = spec{specNodes = map renameCounter (specNodes spec)} - second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed - let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first)) - oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first)) - reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `elem` stale && StaleModule HoleStub oldHoles `elem` stale - doesFileExist (out oldDomain) `shouldReturn` True - doesFileExist (out oldHoles) `shouldReturn` True - it "reports the entire old tree across a module-root flip" $ - withTempDirectory "keiro-dsl-stale-root" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let initialCtx = defaultContext (specContext spec) - rootedCtx = initialCtx{moduleRoot = "Acme"} - first <- executePlannedScaffold out "counter.keiro" initialCtx spec - second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec - reportStale second - `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first] - forM_ (reportStale second) $ \stale -> doesFileExist (out stalePath stale) `shouldReturn` True - renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro") - it "reports moved generated modules across a layout flip" $ - withTempDirectory "keiro-dsl-stale-layout" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let initialCtx = defaultContext (specContext spec) - collocatedCtx = initialCtx{placement = CollocatedLeaf} - first <- executePlannedScaffold out "counter.keiro" initialCtx spec - second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec - let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated] - reportStale second `shouldSatisfy` all (`elem` oldGenerated) - length (reportStale second) `shouldBe` length oldGenerated - it "writes a parseable record and no stale section for a fresh output" $ - withTempDirectory "keiro-dsl-record" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let ctx = defaultContext (specContext spec) - report <- executePlannedScaffold out "counter.keiro" ctx spec - reportStale report `shouldBe` [] - renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:") - contents <- TIO.readFile (out recordFileName (specContext spec)) - parseRecord contents - `shouldBe` Just - ScaffoldRecord - { recSpecPath = "counter.keiro" - , recModuleRoot = "" - , recLayout = "prefixed" - , recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report] - } - parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents - parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing - - describe "faithful scaffold lowering" $ do - it "escapes a trailing-backslash payload literal exactly once" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - case [process | NProcess process <- specNodes spec] of - process : _ -> do - let timer = (procTimer process){tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]} - modules = scaffoldProcess (defaultContext (specContext spec)) process{procTimer = timer} - generatedTextEndingIn "Process.hs" modules - `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)" - [] -> expectationFailure "hospital-surge fixture has no process" - it "preserves quoted Text register initials and refuses unsafe register shapes" $ do - spec <- parseInlineSpec "" loweringAggregateSpec - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec] - domain = generatedTextEndingIn "Domain.hs" modules - domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\"" - scaffoldRefusals spec `shouldBe` [] - bare <- parseInlineSpec "" (T.replace "\"hello world\"" "hello" loweringAggregateSpec) - scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted") - unsupported <- parseInlineSpec "" (T.replace "count:Int" "count:Time" loweringAggregateSpec) - scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable") - it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do - windowSeconds "90s" `shouldBe` Right 90 - windowSeconds "5m" `shouldBe` Right 300 - windowSeconds "2h" `shouldBe` Right 7200 - emitSource <- readTestText "test/fixtures/emit.keiro" - let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource - exponential <- parseInlineSpec "" exponentialSource - case [publisher | NPublisher publisher <- specNodes exponential] of - publisher : _ -> do - let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher) - generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }" - parseSpec "" (renderSpec exponential) `shouldBe` Right exponential - [] -> expectationFailure "emit fixture has no publisher" - constant <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource) - case [publisher | NPublisher publisher <- specNodes constant] of - publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120" - [] -> expectationFailure "emit fixture has no publisher" - it "refuses incomplete exponential backoff and rejects unknown window units" $ do - emitSource <- readTestText "test/fixtures/emit.keiro" - incomplete <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource) - scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete") - parseSpec "" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource) - `shouldSatisfy` leftContains "time unit: s, m, or h" - it "lowers workqueue retry windows in minutes to seconds" $ do - queueSource <- readTestText "test/fixtures/reservation-work.keiro" - queueSpec <- parseInlineSpec "" (T.replace "5s" "5m" queueSource) - case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of - workqueue : _ -> do - let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue) - policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300" - policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)" - [] -> expectationFailure "queue fixture has no workqueue" - it "uses exact status-map keys and emits total Int harness samples" $ do - statusSpec <- parseInlineSpec "" exactStatusSpec - case [aggregate | NAggregate aggregate <- specNodes statusSpec] of - aggregate : _ -> do - let ctx = defaultContext (specContext statusSpec) - projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate) - harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate) - projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\"" - harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0" - harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported" - [] -> expectationFailure "exact-status spec has no aggregate" - - describe "scaffold" $ do - it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - firewallBreaches mods `shouldBe` [] - it "marks the Holes module HoleStub and the rest Generated" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - let holes = [m | m <- mods, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] - map kind holes `shouldBe` [HoleStub] - -- Domain, Codec, EventStream, Projection, Harness. - length [m | m <- mods, kind m == Generated] `shouldBe` 5 - it "is deterministic (re-scaffolding yields byte-identical text)" $ do - a <- scaffoldFixture "test/fixtures/reservation.keiro" - b <- scaffoldFixture "test/fixtures/reservation.keiro" - map moduleText a `shouldBe` map moduleText b - it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated] - it "matches every committed new-surface Generated module (modulo formatting)" $ do - spec <- specOf "test/fixtures/transfer-routing.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - forM_ [m | m <- modules, kind m == Generated] $ \m -> do - committed <- readTestText ("test/conformance-newsurface/" <> modulePath m) - normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) - it "scaffolds the register-free OrderStream smoke target without error" $ do - mods <- scaffoldFixture "test/fixtures/order.keiro" - -- 5 Generated (Domain/Codec/EventStream/Projection/Harness) + 1 Holes. - length mods `shouldBe` 6 - firewallBreaches mods `shouldBe` [] - -syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule -syntheticGenerated path contents = - ScaffoldModule{modulePath = path, moduleText = contents, kind = Generated, origin = "test"} - -generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text -generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of - contents : _ -> contents - [] -> "" - -loweringAggregateSpec :: T.Text -loweringAggregateSpec = - T.unlines - [ "context samples" - , "" - , "aggregate Counter" - , " regs" - , " note Text = \"hello world\"" - , " count Int = 0" - , " state CounterVertex = Pending" - , " states Pending Done!" - , " command Bump { count:Int }" - , " event CountBumped { count:Int }" - , " Pending -- Bump --> emit CountBumped ; goto Done" - ] - -exactStatusSpec :: T.Text -exactStatusSpec = - T.unlines - [ "context samples" - , "" - , "aggregate Reservation" - , " regs" - , " state ReservationVertex = Open" - , " states Open Closed!" - , " command Bump { count:Int }" - , " event ReservationHeld { count:Int }" - , " event ReservationUnHeld { count:Int }" - , " event CountBumped { count:Int }" - , " Open -- Bump --> emit CountBumped ; goto Closed" - , " projection reservation_status consistency=Eventual key=count" - , " status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }" - ] - -hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool -hasPathCollisionWithTwoOrigins = \case - Left refusals -> any hasTwo refusals - Right _ -> False - where - hasTwo (PathCollision _ origins) = length origins == 2 - hasTwo _ = False - -isMissingBannerRefusal :: Either [Refusal] a -> Bool -isMissingBannerRefusal = \case - Left [MissingGeneratedBanner paths] -> not (null paths) - _ -> False - -isSuccessfulScaffold :: Either [Refusal] a -> Bool -isSuccessfulScaffold = \case - Right _ -> True - Left _ -> False - -executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport -executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of - Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable" - Right modules -> do - result <- executeScaffold out False specPath ctx spec modules - case result of - Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable" - Right report -> pure report - -renameCounter :: Node -> Node -renameCounter (NAggregate aggregate) = - NAggregate - aggregate - { aggName = "Widget" - , aggRegs = [reg{regType = if regType reg == "CounterVertex" then "WidgetVertex" else regType reg} | reg <- aggRegs aggregate] - } -renameCounter node = node - -onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath -onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of - [path] -> path - paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths) - -withTempDirectory :: String -> (FilePath -> IO a) -> IO a -withTempDirectory template = bracket acquire removePathForcibly - where - acquire = do - base <- getTemporaryDirectory - (path, handle) <- openTempFile base template - hClose handle - removeFile path - createDirectory path - pure path - -{- | Parse a fixture and return the validator's diagnostic codes (failing the -test on a parse error). --} -diagnosticCodesOf :: FilePath -> IO [DiagnosticCode] -diagnosticCodesOf path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right spec -> pure (map code (validateSpec spec)) - -{- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g. -the benign-inversion notices, are excluded). --} -errorCodesOf :: FilePath -> IO [DiagnosticCode] -errorCodesOf path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right spec -> pure [code d | d <- validateSpec spec, severity d == Error] - --- | Parse two fixtures and diff them (old, new). -diffFixtures :: FilePath -> FilePath -> IO [Change] -diffFixtures oldP newP = do - old <- readTestText oldP - new <- readTestText newP - case (,) <$> parseSpec oldP old <*> parseSpec newP new of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right (o, n) -> pure (diffSpecs o n) - -modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec -modifyReadModel target update spec = - spec - { specNodes = - [ case node of - NReadModel readModel | rmName readModel == target -> NReadModel (update readModel) - _ -> node - | node <- specNodes spec - ] - } - -removeReadModel :: Name -> Spec -> Spec -removeReadModel target spec = - spec{specNodes = [node | node <- specNodes spec, not (isTarget node)]} - where - isTarget (NReadModel readModel) = rmName readModel == target - isTarget _ = False - -modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec -modifyRouter target update spec = - spec - { specNodes = - [ case node of - NRouter router | rtId router == target -> NRouter (update router) - _ -> node - | node <- specNodes spec - ] - } - -routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode] -routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update - -modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec -modifyProcess target update spec = - spec - { specNodes = - [ case node of - NProcess process | procId process == target -> NProcess (update process) - _ -> node - | node <- specNodes spec - ] - } - -processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode] -processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update - -errorCodes :: Spec -> [DiagnosticCode] -errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error] - -changeReadModelShape :: ReadModelNode -> ReadModelNode -changeReadModelShape readModel = - readModel - { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False] - , rmShape = "fnv1a:0000000000000000" - } - -{- | Assert a @new \@ skeleton parses and validates with zero -error-severity diagnostics. --} -assertSkeletonValid :: T.Text -> IO () -assertSkeletonValid kind = case skeletonFor kind of - Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) - Right src -> case parseSpec ("new:" <> T.unpack kind) src of - Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr)) - Right spec -> - [code d | d <- validateSpec spec, severity d == Error] - `shouldBe` ([] :: [DiagnosticCode]) - -assertSkeletonScaffoldable :: T.Text -> IO () -assertSkeletonScaffoldable kind = case skeletonFor kind of - Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) - Right src -> case parseSpec ("new:" <> T.unpack kind) src of - Left perr -> expectationFailure (T.unpack perr) - Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold - -skeletonModuleRoots :: [(T.Text, T.Text)] -skeletonModuleRoots = - [ ("aggregate", "SkelAggregate") - , ("process", "SkelProcess") - , ("router", "SkelRouter") - , ("contract", "SkelContract") - , ("intake", "SkelIntake") - , ("emit", "SkelEmit") - , ("workqueue", "SkelQueue") - , ("workflow", "SkelWorkflow") - ] - -assertSkeletonMatchesCommitted :: T.Text -> T.Text -> IO () -assertSkeletonMatchesCommitted kind root = case skeletonFor kind of - Left err -> expectationFailure (T.unpack err) - Right source -> case parseSpec ("new:" <> T.unpack kind) source of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - let ctx = (defaultContext (specContext spec)){moduleRoot = root} - forM_ [m | m <- scaffoldModules ctx spec, kindOf m == Generated] $ \m -> do - committed <- readTestText ("test/conformance-skeletons/" <> modulePath m) - normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) - where - kindOf = Keiro.Dsl.Scaffold.kind - --- | Parse a fixture into a 'Spec', failing the test on a parse error. -specOf :: FilePath -> IO Spec -specOf path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> error "unreachable" - Right spec -> pure spec - --- | Parse a fixture and scaffold every aggregate in it. -scaffoldFixture :: FilePath -> IO [ScaffoldModule] -scaffoldFixture path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right spec -> - pure $ - concat - [ scaffoldAggregate (ctx spec) spec agg <> harnessFor (ctx spec) spec agg - | NAggregate agg <- specNodes spec - ] - where - ctx spec = defaultContext (specContext spec) - -scaffoldProcessFixture :: FilePath -> IO [ScaffoldModule] -scaffoldProcessFixture path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right spec -> - pure $ concat [scaffoldProcess (ctx spec) p | NProcess p <- specNodes spec] - where - ctx spec = defaultContext (specContext spec) - -{- | Assert a freshly-scaffolded Generated module matches its committed copy -under test/conformance/ (whitespace-normalized). The committed copies are the -ones the keiro-dsl-conformance suite compiles, so this pins the live scaffolder -to known-compiling output. --} -assertMatchesCommitted :: ScaffoldModule -> IO () -assertMatchesCommitted m = do - let committedPath = "test/conformance/" <> modulePath m - committed <- readTestText committedPath - normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) - -normalizeGenerated :: T.Text -> (T.Text, [T.Text]) -normalizeGenerated text = - let (imports, body) = partition isImport (T.lines text) - in (normalizeBody body, sort (map normalizeImport imports)) - where - -- Compare the deterministic body exactly as before and imports as a sorted, - -- whitespace-normalized list. Sorting tolerates formatter reordering while - -- additions, removals, and renamed imports now fail the pin. - normalizeBody = - T.replace " , )" " )" - . T.unwords - . T.words - . T.replace "}" " } " - . T.replace "{" " { " - . T.replace "]" " ] " - . T.replace "[" " [ " - . T.replace "," " , " - . T.unlines - normalizeImport line = - let reordered = case T.words line of - "import" : "qualified" : moduleName : rest -> T.unwords ("import" : moduleName : "qualified" : rest) - wordsInImport -> T.unwords wordsInImport - (prefix, explicit) = T.breakOn " (" reordered - in if T.null explicit - then prefix - else - let members = - sort - . map (T.unwords . T.words) - . T.splitOn "," - . T.dropEnd 1 - $ T.drop 2 explicit - in prefix <> " (" <> T.intercalate "," members <> ")" - isImport line = case T.words line of - "import" : _ -> True - _ -> False - -{- | Locate and read a test fixture or committed conformance source regardless -of whether the suite was launched from the package directory or repo root. --} -readTestText :: FilePath -> IO T.Text -readTestText path = resolveTestPath path >>= TIO.readFile - --- | Locate a repo file regardless of the test process's current directory. -resolveTestPath :: FilePath -> IO FilePath -resolveTestPath rel = do - override <- lookupEnv "KEIRO_DSL_TEST_ROOT" - let candidates = [rel, "keiro-dsl" rel] <> maybe [] (\root -> [root rel]) override - existing <- filterM doesFileExist candidates - case existing of - path : _ -> pure path - [] -> - fail $ - "unable to locate keiro-dsl test file " - <> show rel - <> "; tried " - <> show candidates - -leftContains :: T.Text -> Either T.Text a -> Bool -leftContains needle = \case - Left err -> needle `T.isInfixOf` err - Right _ -> False - -parseInlineSpec :: FilePath -> T.Text -> IO Spec -parseInlineSpec sourceName src = case parseSpec sourceName src of - Left err -> expectationFailure (T.unpack err) >> error "unreachable" - Right spec -> pure spec - -statusMapSpec :: T.Text -> T.Text -statusMapSpec marker = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " event Created { }" - , " event Changed { }" - , "" - , " projection things consistency=Eventual key=thingId" - , " status-map" <> marker <> " { Created=>held }" - ] - -parseErrorOf :: FilePath -> T.Text -> IO T.Text -parseErrorOf sourceName src = case parseSpec sourceName src of - Left err -> pure err - Right _ -> expectationFailure ("expected parse failure for " <> sourceName) >> error "unreachable" - -duplicateGotoSpec :: T.Text -duplicateGotoSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states A B C" - , "" - , " command Go { }" - , " A -- Go -->" - , " goto B" - , " goto C" - ] - -missingGotoSpec :: T.Text -missingGotoSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states A B" - , "" - , " command Go { }" - , " A -- Go -->" - , " emit Changed" - ] - -duplicateWireSpec :: T.Text -duplicateWireSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " wire kind=ctorName fields=camelCase schemaVersion=1" - , " wire kind=typeName fields=snakeCase schemaVersion=2" - ] - -duplicateProjectionSpec :: T.Text -duplicateProjectionSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " projection first consistency=Strong key=thingId" - , " status-map partial { }" - , " projection second consistency=Eventual key=thingId" - ] - -projectionWithoutConsistencySpec :: T.Text -projectionWithoutConsistencySpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " projection things key=thingId" - ] - -malformedRegisterSpec :: T.Text -malformedRegisterSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " status Status" - , " states Open" - ] - -misplacedDispatchIdSpec :: T.Text -misplacedDispatchIdSpec = - T.replace - " schedule timer\n\n dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n" - " dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n schedule timer\n" - (renderSpec (Spec "svc" Nothing Nothing [] [] [] [NProcess (processWithLiteral "literal")])) - -lineNumberContaining :: T.Text -> T.Text -> Int -lineNumberContaining needle = go 1 . T.lines - where - go current = \case - [] -> current - lineText : rest - | needle `T.isInfixOf` lineText -> current - | otherwise -> go (current + 1) rest - -decimalOverflow :: T.Text -decimalOverflow = "18446744073709551617" - -decimalOverflowSpecs :: [(String, T.Text)] -decimalOverflowSpecs = - [ ("event-version", eventVersionDecimalSpec decimalOverflow) - , ("wire-schema", wireDecimalSpec decimalOverflow) - , ("contract-schema", contractDecimalSpec decimalOverflow) - , ("decode-schema", decodeDecimalSpec decimalOverflow) - , ("publisher-attempts", publisherDecimalSpec decimalOverflow) - , ("workqueue-retries", workqueueDecimalSpec decimalOverflow) - , ("timer-attempts", timerDecimalSpec decimalOverflow) - ] - -eventVersionDecimalSpec :: T.Text -> T.Text -eventVersionDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " event Changed v" <> value <> " { }" - ] - -wireDecimalSpec :: T.Text -> T.Text -wireDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "aggregate Thing" - , " regs" - , " states Open" - , "" - , " wire kind=ctorName fields=camelCase schemaVersion=" <> value - ] - -contractDecimalSpec :: T.Text -> T.Text -contractDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "contract Contract {" - , " schemaVersion " <> value - , " discriminator kind" - , "}" - ] - -decodeDecimalSpec :: T.Text -> T.Text -decodeDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "intake Inbox {" - , " contract Contract" - , " topic events" - , " accept Event" - , " dedupe key messageId policy PreferIntegrationMessageId" - , " decode { envelope strict-required lenient-optional body strict schemaVersion == " <> value <> " }" - , " disposition { }" - , "}" - ] - -publisherDecimalSpec :: T.Text -> T.Text -publisherDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "publisher Publisher {" - , " emit Emit" - , " ordering PerKeyHeadOfLine" - , " maxAttempts " <> value - , " backoff constant 2s" - , " outboxId stable from messageId" - , "}" - ] - -workqueueDecimalSpec :: T.Text -> T.Text -workqueueDecimalSpec value = - T.unlines - [ "context svc" - , "" - , "workqueue Queue {" - , " queue logical = \"queue\"" - , " derive physical = \"queue\"" - , " dlq = \"queue_dlq\"" - , " table = \"pgmq.q_queue\"" - , " payload Job { }" - , " retry maxRetries = " <> value <> " delay = 5s dlq = on" - , " disposition { }" - , "}" - ] - -timerDecimalSpec :: T.Text -> T.Text -timerDecimalSpec value = - T.replace - "max-attempts 5" - ("max-attempts " <> value) - (renderSpec (Spec "svc" Nothing Nothing [] [] [] [NProcess (processWithLiteral "literal")])) - -identifierHygieneSpec :: T.Text -identifierHygieneSpec = - T.unlines - [ "context svc" - , "" - , "aggregate thing" - , " regs" - , " states Open" - , "" - , " command DoIt { data }" - ] - -vertexCollisionSpec :: T.Text -vertexCollisionSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Reservation" - , " regs" - , " states Created" - , "" - , " event ReservationCreated { }" - ] - -underscoreNodeSpec :: T.Text -underscoreNodeSpec = - T.unlines - [ "context svc" - , "" - , "contract _contract {" - , " schemaVersion 1" - , " discriminator kind" - , "}" - ] - -unicodeIdentifierSpec :: T.Text -unicodeIdentifierSpec = - T.unlines - [ "context svc" - , "" - , "aggregate Résumé" - , " regs" - , " states Open" - ] - -emptyStatesSpec :: Spec -emptyStatesSpec = - Spec - "svc" - Nothing - Nothing - [] - [] - [] - [NAggregate (Aggregate "Thing" [] [] [] [] [] Nothing Nothing Nothing noLoc)] - -crossFamilyBoundarySpec :: T.Text -crossFamilyBoundarySpec = - T.unlines - [ "context svc" - , "" - , "aggregate First" - , " regs" - , " states A B" - , " command Go { }" - , " A -- Go -->" - , " emit Changed" - , " goto B" - , "" - , "emit Output {" - , " contract Contract" - , " topic events" - , " source \"source\"" - , " key thingId" - , " map status { _ => skip }" - , " messageId derive hole" - , " idempotencyKey derive hole" - , "}" - , "" - , "aggregate Second" - , " regs" - , " states" - , "" - , "dispatch QueueDispatch {" - , " source readModel = source key = thingId" - , " fanout body = resolveFanout" - , " dedup key = thingId" - , " seenIn readModel = seen field = thingId" - , " seenIn queue = workQueue field = thingId" - , " enqueue to = workQueue" - , "}" - ] - --------------------------------------------------------------------------------- --- Generators (bounded; restricted to valid, non-reserved identifiers) --------------------------------------------------------------------------------- - -{- | Text that exercises every supported escape plus notation punctuation that -used to be able to split one emit-map row into several rows. --} -genAdversarialText :: Gen T.Text -genAdversarialText = - T.concat - <$> resize - 20 - (listOf (elements ["a", "Z", "\"", "\\", "\n", "\t", "\r", "=>", "#", "{", "}", " "])) - -{- | One spec carrying the same adversarial value through three distinct -printer paths: a contract topic, an emit-map value, and a quote-wrapped -field-binding literal. --} -escapedSpec :: T.Text -> Spec -escapedSpec value = - Spec - "escape" - Nothing - Nothing - [] - [] - [] - [ NContract - ContractNode - { ctrName = "Contract" - , ctrSchemaVersion = 1 - , ctrDiscriminator = "kind" - , ctrTopics = [("events", value)] - , ctrEvents = [] - , ctrLoc = noLoc - } - , NEmit - EmitNode - { emName = "Emit" - , emContract = "Contract" - , emTopic = "events" - , emSource = "source" - , emKey = "key" - , emDiscriminant = "status" - , emMap = [EmitMapRow value "Event" noLoc] - , emSkip = True - , emMessageId = DeriveSpec Nothing - , emIdempotencyKey = DeriveSpec Nothing - , emLoc = noLoc - } - , NProcess (processWithLiteral value) - ] - -processWithLiteral :: T.Text -> ProcessNode -processWithLiteral value = - ProcessNode - { procId = "Process" - , procName = "process" - , procInput = InputDecl "Input" [] - , procCorrelate = CorrelateDecl "key" "idText" - , procSaga = SagaRef "Saga" "saga" - , procTarget = "Target" - , procProjections = [] - , procHandle = - HandleNode - { hOn = "Input" - , hAdvance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))] - , hDispatch = [] - , hSchedule = "timer" - } - , procRejected = PolHalt - , procPoison = PolHalt - , procTimer = - TimerNode - { tmName = "timer" - , tmId = IdExpr UuidV5Id "timer:" - , tmFireAt = FireAtExpr "observedAt" "5m" - , tmPayload = [] - , tmFire = - FireNode - { fireTarget = "Target" - , fireKey = "correlationId" - , fireCommand = "Fire" - , fireFields = [] - , fireFiredEventId = IdExpr UuidV5Id "fired:" - , fireDisposition = FireDisposition OFired OFired ORetry ORetry ORetry - } - , tmDecodeUnknown = "Cancelled" - , tmMaxAttempts = 5 - , tmDeadLetter = "exhausted" - , tmLoc = noLoc - } - , procLoc = noLoc - } - -genName :: Gen Name -genName = - frequency - [ - ( 3 - , do - base <- elements ["Aa", "Bb", "Cc", "Dd", "St", "Cmd", "Ev", "Reg", "Fld", "Foo", "Bar", "Qux"] - n <- choose (0, 9 :: Int) - pure (T.pack (base <> show n)) - ) - , (1, elements ["data1", "typeA", "whereX", "gotoX", "guardY", "emitZ", "_lead"]) - ] - -genWire :: Gen T.Text -genWire = do - base <- elements ["red", "blue", "green", "ctorName", "camelCase", "rsv", "hosp", "held", "partial-divert", "1st"] - n <- choose (0, 9 :: Int) - pure (T.pack (base <> show n)) - -genWireWord :: Gen T.Text -genWireWord = genWire - -smallList :: Gen a -> Gen [a] -smallList g = choose (0, 3 :: Int) >>= \n -> vectorOf n g - -nonEmptyList :: Gen a -> Gen [a] -nonEmptyList g = choose (1, 3 :: Int) >>= \n -> vectorOf n g - -genMaybe :: Gen a -> Gen (Maybe a) -genMaybe g = oneof [pure Nothing, Just <$> g] - -genCmp :: Gen CmpOp -genCmp = elements [OpEq, OpNeq, OpLt, OpLe, OpGt, OpGe] - -genAtom :: Gen Expr -genAtom = EAtom <$> oneof [AName <$> genName, ABool <$> arbitrary] - -genExpr :: Gen Expr -genExpr = go (3 :: Int) - where - go 0 = genAtom - go d = - oneof - [ genAtom - , EOr <$> go (d - 1) <*> go (d - 1) - , EAnd <$> go (d - 1) <*> go (d - 1) - , ECmp <$> genCmp <*> go (d - 1) <*> go (d - 1) - ] - -genField :: Gen Field -genField = Field <$> genName <*> oneof [pure Nothing, Just <$> genName] - -genReg :: Gen RegDecl -genReg = RegDecl <$> genName <*> genName <*> genRegInitial <*> pure noLoc - -genRegInitial :: Gen RegInitial -genRegInitial = oneof [RegInitBare <$> genName, RegInitText <$> genAdversarialText] - -genState :: Gen StateDecl -genState = StateDecl <$> genName <*> arbitrary <*> pure noLoc - -genCommand :: Gen Command -genCommand = Command <$> genName <*> smallList genField <*> pure noLoc - -genEvent :: Gen Event -genEvent = - Event - <$> genName - <*> body - <*> choose (1, 3) - <*> genMaybe ((,) <$> choose (0, 3) <*> pure Hole) - <*> arbitrary - <*> pure noLoc - where - body = oneof [EventFromCommand <$> genName, EventFields <$> smallList genField] - -genTransition :: Gen Transition -genTransition = - Transition - <$> genName - <*> genName - <*> genMaybe genExpr - <*> smallList ((,) <$> genName <*> genExpr) - <*> smallList genName - <*> genName - <*> pure noLoc - -genWireSpec :: Gen WireSpec -genWireSpec = WireSpec <$> genWire <*> genWire <*> (getNonNegative <$> arbitrary) - -genProjection :: Gen ProjectionSpec -genProjection = - ProjectionSpec - <$> genName - <*> genMaybe (elements [Strong, Eventual]) - <*> genName - <*> genMaybe (Mapping <$> smallList ((,) <$> genName <*> genWire) <*> arbitrary) - <*> pure noLoc - -genAggregate :: Gen Aggregate -genAggregate = - Aggregate - <$> genName - <*> smallList genReg - <*> smallList genState - <*> smallList genCommand - <*> smallList genEvent - <*> smallList genTransition - <*> genMaybe genWireSpec - <*> genMaybe genProjection - <*> genMaybe (SnapshotSpec <$> oneof [SnapEvery <$> choose (0, 5), pure SnapOnTerminal] <*> choose (0, 5) <*> genAdversarialText <*> pure noLoc) - <*> pure noLoc - -genDottedRef :: Gen T.Text -genDottedRef = elements ["input.id", "input.hospitalId", "timer.id", "correlationId", "payload.messageId"] - -genWindow :: Gen T.Text -genWindow = elements ["0s", "5s", "2m", "1h"] - -genFieldBinding :: Gen FieldBinding -genFieldBinding = - FieldBinding - <$> genName - <*> oneof - [ pure Nothing - , Just <$> genDottedRef - , Just . (\raw -> "\"" <> raw <> "\"") <$> genAdversarialText - ] - -genDispatchDisposition :: Gen DispatchDisposition -genDispatchDisposition = DispatchDisposition <$> genDisp <*> genDisp <*> genDisp - where - genDisp = oneof [pure DAckOk, pure DRetry, DDeadLetter <$> genAdversarialText] - -genDispatchNode :: Gen DispatchNode -genDispatchNode = - DispatchNode - <$> genName - <*> genDottedRef - <*> genName - <*> smallList genFieldBinding - <*> genDispatchDisposition - <*> pure noLoc - -genFireDisposition :: Gen FireDisposition -genFireDisposition = - FireDisposition - <$> elements [OFired, ORetry] - <*> elements [OFired, ORetry] - <*> elements [OFired, ORetry] - <*> elements [OFired, ORetry] - <*> elements [OFired, ORetry] - -genIdExpr :: Gen IdExpr -genIdExpr = IdExpr UuidV5Id <$> genAdversarialText - -genFireNode :: Gen FireNode -genFireNode = - FireNode - <$> genName - <*> genDottedRef - <*> genName - <*> smallList genFieldBinding - <*> genIdExpr - <*> genFireDisposition - -genTimerNode :: Gen TimerNode -genTimerNode = - TimerNode - <$> genName - <*> genIdExpr - <*> (FireAtExpr <$> genName <*> genWindow) - <*> smallList genFieldBinding - <*> genFireNode - <*> genName - <*> choose (0, 5) - <*> genAdversarialText - <*> pure noLoc - -genProcess :: Gen ProcessNode -genProcess = - ProcessNode - <$> genName - <*> genAdversarialText - <*> (InputDecl <$> genName <*> smallList genField) - <*> (CorrelateDecl <$> genName <*> genName) - <*> (SagaRef <$> genName <*> genAdversarialText) - <*> genName - <*> smallList genName - <*> (HandleNode <$> genName <*> (AdvanceNode <$> genName <*> smallList genFieldBinding) <*> smallList genDispatchNode <*> genName) - <*> elements [PolHalt, PolDeadLetter, PolSkip] - <*> elements [PolHalt, PolDeadLetter, PolSkip] - <*> genTimerNode - <*> pure noLoc - -genResolveSource :: Gen ResolveSource -genResolveSource = oneof [ResolveReadModel <$> genName, pure ResolveHole] - -genRouter :: Gen RouterNode -genRouter = - RouterNode - <$> genName - <*> genAdversarialText - <*> (InputDecl <$> genName <*> smallList genField) - <*> (CorrelateDecl <$> genName <*> genName) - <*> (ResolveDecl <$> genResolveSource <*> smallList genName <*> pure noLoc) - <*> genName - <*> smallList genName - <*> (RouterDispatchNode <$> genName <*> smallList genFieldBinding <*> genDispatchDisposition <*> pure noLoc) - <*> elements [PolHalt, PolDeadLetter, PolSkip] - <*> elements [PolHalt, PolDeadLetter, PolSkip] - <*> pure noLoc - -genContractField :: Gen ContractField -genContractField = ContractField <$> genName <*> oneof [CTypeId <$> genAdversarialText, pure CText, pure CInt] - -genContractEvent :: Gen ContractEvent -genContractEvent = ContractEvent <$> genName <*> genName <*> smallList genContractField - -genContract :: Gen ContractNode -genContract = - ContractNode - <$> genName - <*> choose (0, 5) - <*> genName - <*> smallList ((,) <$> genName <*> genAdversarialText) - <*> smallList genContractEvent - <*> pure noLoc - -genWireSource :: Gen WireSource -genWireSource = oneof [SrcHeader <$> genAdversarialText, pure SrcBody, pure SrcKafkaKey, pure SrcKafkaCursor] - -genInboxAction :: Gen InboxAction -genInboxAction = oneof [pure IAckOk, IRetry <$> genWindow, IDeadLetter <$> genMaybe genAdversarialText] - -genDispositionRow :: Gen DispositionRow -genDispositionRow = DispositionRow <$> genName <*> genInboxAction <*> pure noLoc - -genDecodeSpec :: Gen DecodeSpec -genDecodeSpec = - DecodeSpec - <$> ((\first second -> first <> " " <> second) <$> genWireWord <*> genWireWord) - <*> arbitrary - <*> choose (0, 5) - -genIntake :: Gen IntakeNode -genIntake = - IntakeNode - <$> genName - <*> genName - <*> genName - <*> nonEmptyList genName - <*> smallList (BindRow <$> genName <*> genWireSource <*> arbitrary <*> arbitrary) - <*> genName - <*> genName - <*> elements [InkPersistFull, InkPersistDedupeOnly] - <*> genDecodeSpec - <*> smallList genDispositionRow - <*> pure noLoc - -genDeriveSpec :: Gen DeriveSpec -genDeriveSpec = DeriveSpec <$> genMaybe genAdversarialText - -genEmit :: Gen EmitNode -genEmit = - EmitNode - <$> genName - <*> genName - <*> genName - <*> genAdversarialText - <*> genName - <*> genName - <*> smallList (EmitMapRow <$> genAdversarialText <*> genName <*> pure noLoc) - <*> arbitrary - <*> genDeriveSpec - <*> genDeriveSpec - <*> pure noLoc - -genPublisher :: Gen PublisherNode -genPublisher = - PublisherNode - <$> genName - <*> genName - <*> genName - <*> choose (0, 5) - <*> (BackoffSpec <$> genName <*> genWindow <*> genMaybe genWindow <*> genMaybe (elements ["1.0", "2.0", "3"])) - <*> genName - <*> pure noLoc - -genWqField :: Gen WqField -genWqField = WqField <$> genName <*> genAdversarialText <*> genName <*> arbitrary - -genWqDispRow :: Gen WqDispRow -genWqDispRow = WqDispRow <$> genName <*> genInboxAction <*> pure noLoc - -genWorkqueue :: Gen WorkqueueNode -genWorkqueue = - WorkqueueNode - <$> genName - <*> genAdversarialText - <*> genAdversarialText - <*> genAdversarialText - <*> genAdversarialText - <*> elements [WqUnordered, WqFifoThroughput, WqFifoRoundRobin] - <*> genMaybe (WqGroupKey <$> genName <*> genName <*> genMaybe genAdversarialText) - <*> oneof [pure WqStandard, pure WqUnlogged, WqPartitioned <$> genAdversarialText <*> genAdversarialText] - <*> genName - <*> smallList genWqField - <*> choose (0, 5) - <*> genWindow - <*> arbitrary - <*> smallList genWqDispRow - <*> pure noLoc - -genReadModel :: Gen ReadModelNode -genReadModel = - ReadModelNode - <$> genName - <*> genAdversarialText - <*> genAdversarialText - <*> smallList (RmColumn <$> genWireWord <*> genName <*> arbitrary) - <*> choose (0, 5) - <*> genAdversarialText - <*> elements [Strong, Eventual] - <*> genMaybe (oneof [pure RmEntireLog, RmCategory <$> genAdversarialText]) - <*> elements [RmInline, RmSubscription] - <*> genMaybe genAdversarialText - <*> pure noLoc - -genPgmqDispatch :: Gen PgmqDispatchNode -genPgmqDispatch = - PgmqDispatchNode - <$> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> genName - <*> pure noLoc - -genWfBodyItem :: Gen WfBodyItem -genWfBodyItem = sized go - where - go size = - oneof $ - [ WfStep <$> genWireWord <*> genName <*> pure noLoc - , WfAwait <$> genWireWord <*> genName <*> pure noLoc - , WfSleep <$> genWireWord <*> genName <*> pure noLoc - , WfChild <$> genWireWord <*> genName <*> genName <*> pure noLoc - , WfContinueAsNew <$> genName <*> pure noLoc - ] - ++ [ WfPatch <$> genWireWord <*> resize (size `div` 2) (smallList genWfBodyItem) <*> pure noLoc - | size > 0 - ] - -genWorkflow :: Gen WorkflowNode -genWorkflow = - WorkflowNode - <$> genName - <*> genAdversarialText - <*> genName - <*> smallList genField - <*> genName - <*> genMaybe genName - <*> genName - <*> smallList genWfBodyItem - <*> pure noLoc - -genOperationShape :: Gen OperationShape -genOperationShape = - oneof - [ CommandOp <$> genName <*> genName <*> genName <*> smallList genName - , QueryOp <$> genName <*> genName <*> ((\parts -> T.unwords parts) <$> nonEmptyList genName) <*> genName - , SignalOp <$> genWireWord <*> genName <*> genName <*> genName <*> genName - , RunOp <$> genName <*> genName <*> genName - ] - -genOperation :: Gen OperationNode -genOperation = OperationNode <$> genName <*> genOperationShape <*> pure noLoc - -allNodeTags :: [String] -allNodeTags = ["aggregate", "process", "router", "contract", "intake", "emit", "publisher", "workqueue", "pgmq-dispatch", "readmodel", "workflow", "operation"] - -nodeTag :: Node -> String -nodeTag = \case - NAggregate _ -> "aggregate" - NProcess _ -> "process" - NRouter _ -> "router" - NContract _ -> "contract" - NIntake _ -> "intake" - NEmit _ -> "emit" - NPublisher _ -> "publisher" - NWorkqueue _ -> "workqueue" - NPgmqDispatch _ -> "pgmq-dispatch" - NReadModel _ -> "readmodel" - NWorkflow _ -> "workflow" - NOperation _ -> "operation" - -genId :: Gen IdDecl -genId = IdDecl <$> genName <*> genWire <*> pure noLoc - -genEnum :: Gen EnumDecl -genEnum = EnumDecl <$> genName <*> smallList ((,) <$> genName <*> genWire) <*> pure noLoc - -genRule :: Gen RuleDecl -genRule = - RuleDecl - <$> genName - <*> genName - <*> genName - <*> nonEmptyList ((,) <$> genName <*> genExpr) - <*> pure noLoc - -genSpec :: Gen Spec -genSpec = - Spec - <$> genWire - <*> genMaybe genModuleRoot - <*> genMaybe (elements [GeneratedPrefix, CollocatedLeaf]) - <*> smallList genId - <*> smallList genEnum - <*> smallList genRule - <*> smallList genNode +{-# LANGUAGE ImportQualifiedPost #-} + +{- | Test driver for keiro-dsl. EP-1 milestone 1 tests: the @parse . pretty@ +round-trip property over generated specs, and a unit test pinning the shape +of the canonical Reservation fixture. +-} +module Main (main) where + +import Control.Exception (bracket) +import Control.Monad (filterM, forM, forM_, unless) +import Data.Aeson (Value, object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Either (isLeft, isRight) +import Data.List (partition, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Keiro.Codec (Codec (..), EventType (..), decodeRaw) +import Keiro.Dsl.CodecCompare +import Keiro.Dsl.Coverage qualified as Coverage +import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, diffSpecs, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor) +import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding) +import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingObligations, renderBindingObligations) +import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint, aggregateFoldSurface) +import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff) +import Keiro.Dsl.Grammar +import Keiro.Dsl.Harness (harnessFor, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow) +import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest) +import Keiro.Dsl.MappedConsumer (ConsumerPlan (..)) +import Keiro.Dsl.Parser (parseSpec) +import Keiro.Dsl.PrettyPrint (renderSpec, renderTransition) +import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) +import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..)) +import Keiro.Dsl.ReplayImpact qualified as ReplayImpact +import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, holePrefixFor, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldWorkqueue, windowSeconds) +import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) +import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), StaleModule (..), WriteDisposition (..), executeScaffold, planScaffold, renderRefusals, renderScaffoldReport, scaffoldModules) +import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, validateSpec) +import System.Directory (createDirectory, createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.IO (hClose, openTempFile) +import System.Process (readProcessWithExitCode) +import Test.Hspec hiding (Spec) +import Test.QuickCheck + +main :: IO () +main = hspec $ do + describe "historical codec comparison" $ do + it "treats object-key order as RFC 8785 parity" $ do + let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)] + generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)] + classifyObservation (EncodeObservation "ordered-object" historical generated) + `shouldBe` Right JsonParity + it "classifies an omitted key versus explicit null as version work at that pointer" $ do + let historical = object [] + generated = object ["description" .= Aeson.Null] + classifyObservation (EncodeObservation "absent-description" historical generated) + `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated)) + it "classifies generated rejection of a historical value as version work" $ + classifyObservation + ( DecodeObservation + "legacy.json" + (object ["tag" .= ("legacy" :: T.Text)]) + (DecodedShape (object ["tag" .= ("legacy" :: T.Text)])) + (DecodeFailed "unknown tag") + ) + `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag")) + it "treats historical-codec rejection as invalid input rather than parity" $ + classifyObservation + ( DecodeObservation + "corrupt.json" + Aeson.Null + (DecodeFailed "not historical data") + (DecodeFailed "not generated data") + ) + `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data") + it "reports uncovered union arms separately by corpus origin" $ do + let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file") + report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")] + crCoverageGaps report + `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")] + reportSucceeded report `shouldBe` False + it "derives optional, null, and union-arm observations from a generated branch schema" $ do + let schema = + BranchRecord + [ BranchField "description" True (BranchOptional BranchScalar) + , BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing]) + ] + historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]] + observedBranchesFor HistoricalGolden schema historical + `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing + , ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + ] + let declared = declaredBranchesFor HistoricalGolden schema + forM_ + [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing + , DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent + , DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull + , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local") + , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + ] + (\branch -> declared `shouldContain` [branch]) + it "round-trips the stable machine report" $ do + let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)]) + report = compareReport comparisonProvenance [] [observation] [] [] + Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report + it "atomically writes and replaces the machine report" $ + withTempDirectory "keiro-dsl-codec-compare" $ \out -> do + let path = out "report.json" + firstReport = compareReport comparisonProvenance [] [] [] [] + secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] [] + writeCompareReportAtomic path firstReport `shouldReturn` Right () + Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport + writeCompareReportAtomic path secondReport `shouldReturn` Right () + Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport + + describe "historical codec comparison scaffold" $ do + it "emits an opt-in non-production runner without entering the ordinary module registry" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + let ctx = defaultContext (specContext spec) + planned = codecComparisonModule ctx spec "ArtifactInfo" + ordinary = scaffoldModules ctx spec + case planned of + Left err -> expectationFailure (T.unpack err) + Right comparisonModule -> do + modulePath comparisonModule + `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs" + moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner + moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec" + moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord" + map modulePath ordinary `shouldNotContain` [modulePath comparisonModule] + it "refuses opaque selections rather than upgrading their claim" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry" + `shouldSatisfy` either (T.isInfixOf "is opaque") (const False) + + describe "structural/opaque coverage reporting" $ do + it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + report <- shouldResolveCoverage "structural-conformance.keiro" spec + Coverage.privateEventPayloads (Coverage.coverageSummary report) + `shouldBe` Coverage.CoverageCounts 2 1 1 0 + Coverage.snapshotRegisters (Coverage.coverageSummary report) + `shouldBe` Coverage.CoverageCounts 2 1 1 0 + map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report) + `shouldBe` ["VendorGeometry"] + map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report) + `shouldBe` ["consumer-json-cache", "consumer-json-cache"] + map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report) + `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"] + map Coverage.findingCode (Coverage.coverageFindings report) + `shouldBe` [CoverageOpaqueSurface] + map Coverage.findingSeverity (Coverage.coverageFindings report) + `shouldBe` [Warning] + case Aeson.toJSON report of + Aeson.Object values -> + forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $ + \key -> KeyMap.member key values `shouldBe` True + value -> expectationFailure ("coverage report was not an object: " <> show value) + it "reports explicit Json leaves by their complete persisted path" $ do + spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro" + report <- shouldResolveCoverage "structural-conformance-json.keiro" spec + Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report)) + `shouldBe` 1 + map Coverage.jsonPath (Coverage.coverageJsonBoundaries report) + `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"] + it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do + original <- specOf "test/fixtures/structural-conformance.keiro" + clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original) + Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0 + Coverage.coverageOpaqueBoundaries clear `shouldBe` [] + Coverage.coverageFindings clear `shouldBe` [] + opaque <- shouldResolveCoverage "structural-conformance.keiro" original + Coverage.coverageSucceeded opaque `shouldBe` True + let gated = Coverage.failOnOpaque opaque + Coverage.coverageSucceeded gated `shouldBe` False + map Coverage.findingCode (Coverage.coverageFindings gated) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded] + map Coverage.findingSeverity (Coverage.coverageFindings gated) + `shouldBe` [Warning, Error] + it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do + newSpec <- specOf "test/fixtures/structural-conformance.keiro" + report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of + Left err -> expectationFailure (show err) >> fail "unreachable" + Right value -> pure value + fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1 + fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report) + `shouldBe` Just ["VendorGeometry"] + map Coverage.findingCode (Coverage.coverageFindings report) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded] + Coverage.coverageSucceeded report `shouldBe` True + let gated = Coverage.failOnOpaqueIncrease report + Coverage.coverageSucceeded gated `shouldBe` False + map Coverage.findingCode (Coverage.coverageFindings gated) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded] + it "appends the six stable coverage and comparison registry codes" $ + map + show + [ CoverageOpaqueSurface + , CoverageOpaqueBoundaryAdded + , CoverageOpaqueGateExceeded + , CodecCompareDifference + , CodecCompareCoverageGap + , CodecCompareInvalidInput + ] + `shouldBe` [ "CoverageOpaqueSurface" + , "CoverageOpaqueBoundaryAdded" + , "CoverageOpaqueGateExceeded" + , "CodecCompareDifference" + , "CodecCompareCoverageGap" + , "CodecCompareInvalidInput" + ] + + describe "parse . pretty round-trip" $ + do + it "re-parses any generated spec to an equal AST (modulo source locations)" $ + checkCoverage $ + forAll genSpec $ \s -> + let families = map nodeTag (specNodes s) + roundTrip = parseSpec "" (renderSpec s) === Right s + in cover 5 (not (null (specMapped s))) "mapped" $ + foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags + it "round-trips an aggregate with no states" $ + parseSpec "" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec + it "separates transition emit clauses from following nodes" $ do + spec <- parseInlineSpec "" crossFamilyBoundarySpec + case specNodes spec of + [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do + concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"] + aggStates second `shouldBe` [] + nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes)) + + describe "mapped types (EP-149)" $ do + it "round-trips the canonical structural and opaque consumer fixture" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + parseSpec "" (renderSpec spec) `shouldBe` Right spec + length (specMapped spec) `shouldBe` 4 + it "preserves every missing-value policy, nested type expression, and unit union arm" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + let fields = [field | MappedStructural{msShape = ShapeRecord _ _ recordFields} <- specMapped spec, field <- recordFields] + arms = [arm | MappedStructural{msShape = ShapeUnion _ unionArms} <- specMapped spec, arm <- unionArms] + [value | field <- fields, Just value <- [wfOnMissing field]] + `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap] + [wfType field | field <- fields, wfHaskell field == "labels"] + `shouldBe` [TList (TOptional TText)] + [waCtor arm | arm <- arms, waPayload arm == Nothing] + `shouldBe` ["Unknown"] + it "rejects every mapped validation fixture with its stable diagnostic code" $ do + let cases = + [ ("mapped-unresolved.keiro", MappedUnresolvedName) + , ("mapped-ambiguous.keiro", MappedAmbiguousName) + , ("mapped-dup-fieldname.keiro", MappedDuplicateFieldName) + , ("mapped-dup-wirekey.keiro", MappedDuplicateWireKey) + , ("mapped-dup-armname.keiro", MappedDuplicateArmName) + , ("mapped-dup-tag.keiro", MappedDuplicateWireTag) + , ("mapped-recursive.keiro", MappedRecursiveType) + , ("mapped-recursive-mutual.keiro", MappedRecursiveType) + , ("mapped-bad-encoding.keiro", MappedUnsupportedEncoding) + , ("mapped-union-key-collision.keiro", MappedUnsupportedEncoding) + , ("mapped-optional-json.keiro", MappedNonInjectiveNullability) + , ("mapped-optional-optional.keiro", MappedNonInjectiveNullability) + , ("mapped-optional-opaque.keiro", MappedNonInjectiveNullability) + , ("mapped-missing-binding.keiro", MappedMissingIngredient) + , ("mapped-missing-binding-version.keiro", MappedMissingIngredient) + , ("mapped-missing-canonical.keiro", MappedMissingIngredient) + , ("mapped-missing-fixture.keiro", MappedMissingIngredient) + , ("mapped-missing-initial.keiro", MappedMissingInitialValue) + , ("mapped-bad-haskell-name.keiro", MappedInvalidHaskellName) + , ("mapped-empty-identity.keiro", MappedInvalidIdentity) + , ("mapped-import-conflict.keiro", MappedImportConflict) + , ("mapped-illtyped-default.keiro", MappedDefaultIllTyped) + , ("mapped-guard.keiro", MappedGuardUnsupported) + , ("mapped-guard-natural.keiro", MappedGuardUnsupported) + ] + forM_ cases $ \(fixture, expected) -> + errorCodesOf ("test/fixtures/" <> fixture) `shouldReturn` [expected] + it "keeps Time in Keiki's curated guard set while rejecting Natural" $ + errorCodesOf "test/fixtures/mapped-guard-time.keiro" `shouldReturn` [] + it "rejects required defaults, missing optional policies, Int overflow, and negative Natural defaults" $ do + let invalidFields = + [ WireField "requiredDefault" "requiredDefault" TText PRequired (Just (OmText "x")) noLoc + , WireField "missingPolicy" "missingPolicy" TText POptional Nothing noLoc + , WireField "overflow" "overflow" TInt POptional (Just (OmInt (toInteger (maxBound :: Int) + 1))) noLoc + , WireField "negativeNatural" "negativeNatural" TNatural POptional (Just (OmInt (-1))) noLoc + ] + declaration = completeStructural "Defaults" (ShapeRecord "Defaults" RejectUnknown invalidFields) + errorCodes (mappedSpec [declaration]) + `shouldBe` [MappedDefaultIllTyped, MappedMissingIngredient, MappedDefaultIllTyped, MappedDefaultIllTyped] + + describe "mapped type graph (EP-149)" $ do + it "resolves checked declarations, transitive reachability, and every aggregate root path" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + graph <- shouldResolveTypeGraph spec + Map.size (tgDeclarations graph) `shouldBe` 4 + Map.lookup (MappedKey "ArtifactInfo") (tgReachability graph) + `shouldBe` Just (Set.fromList [MappedKey "ArtifactKind", MappedKey "ArtifactLocation"]) + map renderUsePath (usePaths graph "ArtifactLocation") + `shouldBe` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation" + , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation" + , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation" + ] + it "resolves every builtin through the complete expression algebra" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + graph <- shouldResolveTypeGraph spec + case Map.lookup (MappedKey "ArtifactInfo") (tgDeclarations graph) of + Just (ResolvedStructural _ (RRecord _ _ fields)) -> + Set.fromList (concatMap (foldTypeExpr expressionTags . rwfType) fields) + `shouldBe` Set.fromList ["text", "int", "bool", "natural", "time", "json", "optional", "list", "map", "ref:ArtifactKind", "ref:ArtifactLocation"] + declaration -> expectationFailure ("unexpected ArtifactInfo declaration: " <> show declaration) + it "rejects direct, mutual, wrapped, and union-arm recursion" $ do + let direct = mappedSpec [completeStructural "A" (recordShape [TRef "A"])] + mutual = mappedSpec [completeStructural "A" (recordShape [TRef "B"]), completeStructural "B" (recordShape [TRef "A"])] + wrapped = mappedSpec [completeStructural "A" (recordShape [TList (TOptional (TRef "A"))])] + throughArm = mappedSpec [completeStructural "A" (ShapeUnion (TaggedObject "tag" "contents" RejectUnknown) [WireArm "Again" "again" (Just (TRef "A")) noLoc])] + map (hasTypeGraphError isRecursive . resolveTypeGraph) [direct, mutual, wrapped, throughArm] + `shouldBe` replicate 4 True + it "keeps existing ids and enums outside the mapped-reference namespace" $ do + let spec = + (mappedSpec [completeStructural "A" (recordShape [TRef "ExistingId"])]) + { specIds = [IdDecl "ExistingId" "id" noLoc] + } + resolveTypeGraph spec `shouldSatisfy` hasTypeGraphError isUnresolved + it "fingerprints wire identity while ignoring Haskell selector names" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + base <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + baseGraph <- shouldResolveTypeGraph base + haskellRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfHaskell = "renamedKey"}) base) + wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfKey = "renamed_key"}) base) + wireFingerprint haskellRenameGraph "ArtifactInfo" `shouldBe` wireFingerprint baseGraph "ArtifactInfo" + wireFingerprint wireRenameGraph "ArtifactInfo" `shouldNotBe` wireFingerprint baseGraph "ArtifactInfo" + + describe "string literal integrity" $ do + it "parses an escaped emit-map value as exactly one row" $ do + let src = + T.unlines + [ "context svc" + , "" + , "emit e {" + , " contract c" + , " topic events" + , " source \"svc\"" + , " key thingId" + , " map status {" + , " \"a\\\" => Wat \\\"b\" => ThingAccepted" + , " _ => skip" + , " }" + , " messageId derive hole" + , " idempotencyKey derive hole" + , "}" + ] + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of + [row] -> do + emrValue row `shouldBe` "a\" => Wat \"b" + emrEvent row `shouldBe` "ThingAccepted" + rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows)) + it "rejects a raw newline inside a quoted string" $ do + let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"first\nsecond\"\n}\n" + parseSpec "" src `shouldSatisfy` leftContains "unescaped newline" + it "rejects an unknown escape sequence" $ do + let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"bad\\q\"\n}\n" + parseSpec "" src `shouldSatisfy` leftContains "unknown escape" + it "round-trips adversarial text through topics, emit maps, and quoted bindings" $ + property $ + forAll genAdversarialText $ \t -> + let spec = escapedSpec t + rendered = renderSpec spec + in counterexample (T.unpack rendered) (parseSpec "" rendered === Right spec) + + describe "partial status maps" $ do + it "suppresses totality only when the partial marker is present" $ do + partial <- parseInlineSpec "" (statusMapSpec " partial") + totalSpec <- parseInlineSpec "" (statusMapSpec "") + map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal] + map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal] + parseSpec "" (renderSpec partial) `shouldBe` Right partial + + describe "positioned parser diagnostics" $ do + it "rejects a duplicate goto at the second clause" $ do + err <- parseErrorOf "" duplicateGotoSpec + err `shouldSatisfy` T.isInfixOf "duplicate goto" + err `shouldSatisfy` T.isInfixOf ":10:" + it "rejects duplicate wire and projection blocks at their second occurrences" $ do + wireErr <- parseErrorOf "" duplicateWireSpec + wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block" + wireErr `shouldSatisfy` T.isInfixOf ":8:" + projectionErr <- parseErrorOf "" duplicateProjectionSpec + projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block" + projectionErr `shouldSatisfy` T.isInfixOf ":9:" + it "anchors a missing goto on the transition line" $ do + err <- parseErrorOf "" missingGotoSpec + err `shouldSatisfy` T.isInfixOf "missing a goto clause" + err `shouldSatisfy` T.isInfixOf ":8:" + it "stops before a misplaced dispatch-id and expects schedule at its start" $ do + let src = misplacedDispatchIdSpec + expectedPosition = + ":" + <> T.pack (show (lineNumberContaining "dispatch-id" src)) + <> ":5:" + err <- parseErrorOf "" src + err `shouldSatisfy` T.isInfixOf "schedule" + err `shouldSatisfy` T.isInfixOf expectedPosition + it "keeps a malformed register declaration's equals error" $ do + err <- parseErrorOf "" malformedRegisterSpec + err `shouldSatisfy` T.isInfixOf "expecting '='" + + describe "bounded decimal literals" $ do + forM_ decimalOverflowSpecs $ \(site, src) -> + it ("rejects overflow at " <> site) $ do + err <- parseErrorOf (" site <> ">") src + err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range") + it "accepts maxBound without changing its value" $ do + spec <- parseInlineSpec "" (wireDecimalSpec (T.pack (show (maxBound :: Int)))) + [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]] + `shouldBe` [maxBound] + + describe "identifier hygiene" $ do + it "reports constructor shape and Haskell keywords at their owning declarations" $ do + spec <- parseInlineSpec "" identifierHygieneSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentNotConstructorSafe, IdentHaskellKeyword]] + `shouldContain` [(IdentNotConstructorSafe, 3), (IdentHaskellKeyword, 7)] + it "rejects generated vertex constructors that collide with event constructors" $ do + spec <- parseInlineSpec "" vertexCollisionSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision] + `shouldBe` [(VertexCtorCollision, 3)] + it "rejects underscore-leading names whose title-casing cannot make a module segment" $ do + spec <- parseInlineSpec "" underscoreNodeSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe] + `shouldBe` [(IdentNotConstructorSafe, 3)] + it "rejects non-ASCII identifier characters in the parser" $ + parseSpec "" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected" + + describe "canonical reservation.keiro" $ + it "parses into the expected aggregate shape" $ do + input <- readTestText "test/fixtures/reservation.keiro" + case parseSpec "test/fixtures/reservation.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specContext spec `shouldBe` "hospital-capacity" + length (specIds spec) `shouldBe` 3 + length (specEnums spec) `shouldBe` 3 + length (specRules spec) `shouldBe` 1 + case specNodes spec of + [NAggregate a] -> do + aggName a `shouldBe` "Reservation" + length (aggStates a) `shouldBe` 6 + length (aggCommands a) `shouldBe` 2 + length (aggEvents a) `shouldBe` 2 + length (aggTransitions a) `shouldBe` 2 + map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True] + other -> expectationFailure ("expected one aggregate node, got " <> show (length other)) + + describe "validator" $ do + it "accepts the canonical reservation.keiro" $ do + codes <- errorCodesOf "test/fixtures/reservation.keiro" + codes `shouldBe` [] + it "rejects a missing status-map as StatusMapNotTotal" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro" + codes `shouldContain` [StatusMapNotTotal] + it "rejects an undeclared command as UndeclaredCommand" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro" + codes `shouldContain` [UndeclaredCommand] + it "rejects a wall-clock guard atom as ClockSampled" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro" + codes `shouldContain` [ClockSampled] + it "accepts a v2 event with a contiguous upcaster hole" $ do + codes <- errorCodesOf "test/fixtures/reservation-v2.keiro" + codes `shouldBe` [] + it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro" + codes `shouldContain` [EvtVersionMissingUpcaster] + it "accepts shared upcaster sources for different event kinds" $ do + codes <- errorCodesOf "test/fixtures/reservation-dup-upcast-source.keiro" + codes `shouldNotContain` [DuplicateUpcasterSource] + it "rejects a gap in the aggregate-global upcaster chain" $ do + codes <- errorCodesOf "test/fixtures/reservation-chain-gap.keiro" + codes `shouldContain` [UpcasterChainGap] + it "warns while a retiring event keeps its live emitting transition" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-retiring.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [EventRetirementInProgress] + it "rejects a retiring event after its live emitting transition disappears" $ do + source <- readTestText "test/fixtures/reservation-retiring.keiro" + spec <- parseInlineSpec "" (T.replace " ; emit TransferReservationConfirmed" "" source) + [code d | d <- validateSpec spec, severity d == Error] + `shouldContain` [EventRetirementInProgress] + it "warns when a deprecated event has no replay-only emitting transition" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [DeprecatedEventReplayHazard] + it "recognises deprecated plus replay-only as the replay-safe cutover" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [EventRetirementInProgress] + [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard] + it "requires exact, unique status-map event keys" $ do + dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro" + mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal] + duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro" + duplicate `shouldContain` [StatusMapDuplicateKey] + it "rejects duplicate spec and aggregate names" $ do + codes <- errorCodesOf "test/fixtures/duplicate-names.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [ DuplicateNodeName + , DuplicateEnumCtor + , DuplicateEnumWire + , DuplicateIdPrefix + , DuplicateCommandName + , DuplicateEventName + ] + it "rejects aggregate-local references that do not resolve" $ do + codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro" + codes `shouldContain` [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister] + it "anchors UnreachableState on the state row" $ do + let src = + T.unlines + [ "context repro" + , "" + , "aggregate Thing" + , " regs" + , " states" + , " Initial" + , " Unreachable" + ] + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> + [line d | d <- validateSpec spec, code d == UnreachableState] + `shouldBe` [7] + it "accepts a replay-only twin with a live sibling (plan 143)" $ do + codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro" + codes `shouldBe` [] + it "rejects a replay-only transition that emits nothing" $ do + case parseSpec "" (replayOnlySpecWith [" write reservationState := Held", " goto Held"]) of + Left err -> expectationFailure (T.unpack err) + Right spec -> + [code d | d <- validateSpec spec, severity d == Error] + `shouldContain` [ReplayOnlyEmitsNothing] + it "warns when a replay-only transition has no live sibling" $ do + case parseSpec "" (replayOnlySpecWith [" emit TransferReservationCreated", " goto Held"]) of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + [code d | d <- validateSpec spec, severity d == Warning] + `shouldContain` [ReplayOnlyCommandStillLive] + [code d | d <- validateSpec spec, severity d == Error] + `shouldNotContain` [ReplayOnlyCommandStillLive] + + describe "complementExpr (plan 143)" $ do + it "applies De Morgan over and/or and flips comparison operators" $ do + let a = EAtom (AName "a") + b = EAtom (AName "b") + complementExpr (EAnd a b) + `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False))) + complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b + complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b + complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b + complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b + complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b + complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b + it "flips boolean literals and grounds bare names as == false" $ do + complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False) + complementExpr (EAtom (AName "open")) + `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False)) + it "stays inside the grammar: the complement of any guard re-parses" $ + property $ + forAll genExpr $ \e -> + let twin = + replayOnlySpecWith + [ " guard " <> renderExprText (complementExpr e) + , " emit TransferReservationCreated" + , " goto Held" + ] + in case parseSpec "" twin of + Left err -> counterexample (T.unpack err) False + Right spec -> + [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a] + === [Just (complementExpr e)] + + describe "evolution parsing" $ do + it "parses event version and upcaster from reservation-v2.keiro" $ do + input <- readTestText "test/fixtures/reservation-v2.keiro" + case parseSpec "test/fixtures/reservation-v2.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of + (e : _) -> do + evVersion e `shouldBe` 2 + evUpcastFrom e `shouldBe` Just (1, Hole) + [] -> expectationFailure "TransferReservationCreated not found" + it "round-trips the retiring marker" $ do + spec <- specOf "test/fixtures/reservation-retiring.keiro" + parseSpec "" (renderSpec spec) `shouldBe` Right spec + [evRetiring event | NAggregate aggregate <- specNodes spec, event <- aggEvents aggregate, evName event == "TransferReservationConfirmed"] + `shouldBe` [True] + it "rejects an event marked both retiring and deprecated" $ do + source <- readTestText "test/fixtures/reservation-retiring.keiro" + let conflicting = T.replace "retiring event TransferReservationConfirmed" "retiring deprecated event TransferReservationConfirmed" source + parseSpec "" conflicting `shouldSatisfy` isLeft + + describe "aggregate snapshots (EP-109)" $ do + it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do + spec <- specOf "test/fixtures/reservation-snapshot.keiro" + errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` [] + parseSpec "" (renderSpec spec) `shouldBe` Right spec + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc" noLoc) + aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates)) + it "rejects disabled intervals and invalid codec fixtures" $ do + source <- readTestText "test/fixtures/reservation-snapshot.keiro" + interval <- parseInlineSpec "" (T.replace "snapshot every 100" "snapshot every 0" source) + map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid] + version <- parseInlineSpec "" (T.replace "state-codec version=1" "state-codec version=0" source) + map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid] + emptyHash <- parseInlineSpec "" (T.replace "shape-hash=\"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\"" "shape-hash=\"\"" source) + map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid] + it "conditionally lowers JSON instances and the live defaultStateCodec" $ do + snapshot <- specOf "test/fixtures/reservation-snapshot.keiro" + ordinary <- specOf "test/fixtures/reservation.keiro" + case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of + ([snapshotAggregate], [ordinaryAggregate]) -> do + let snapshotModules = scaffoldAggregate (defaultContext (specContext snapshot)) snapshot snapshotAggregate + ordinaryModules = scaffoldAggregate (defaultContext (specContext ordinary)) ordinary ordinaryAggregate + snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules + snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules + ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules + ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules + snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)" + snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100" + snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (withFoldFingerprint" + snapshotStream `shouldSatisfy` T.isInfixOf "Spec-visible fold changes invalidate old" + snapshotStream `shouldSatisfy` T.isInfixOf "module are invisible here" + snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\")" + ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass" + ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never" + ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing" + ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\"" + firewallBreaches snapshotModules `shouldBe` [] + _ -> expectationFailure "expected one aggregate in each snapshot test spec" + + describe "aggregate fold fingerprints (plan 138)" $ do + it "is deterministic across repeated parses and formatting-only changes" $ do + source <- readTestText "test/fixtures/reservation.keiro" + first <- parseInlineSpec "" source + second <- parseInlineSpec "" ("\n\n" <> renderSpec first <> "\n") + aggregateFoldFingerprint first (onlyAggregate first) + `shouldBe` aggregateFoldFingerprint second (onlyAggregate second) + it "changes for transition writes, guards, and referenced rule bodies" $ do + base <- specOf "test/fixtures/reservation.keiro" + writeChanged <- specOf "test/fixtures/reservation-foldchange.keiro" + guardChanged <- specOf "test/fixtures/reservation-guard-tightened.keiro" + source <- readTestText "test/fixtures/reservation.keiro" + ruleChanged <- parseInlineSpec "" (T.replace "RedTag => true" "RedTag => false" source) + let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) + aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint + it "ignores wire and projection changes" $ do + base <- specOf "test/fixtures/reservation.keiro" + wireChanged <- specOf "test/fixtures/reservation-wire.keiro" + source <- readTestText "test/fixtures/reservation.keiro" + projectionChanged <- parseInlineSpec "" (T.replace "projection transfer_decisions" "projection renamed_projection" source) + let surface = aggregateFoldSurface base (onlyAggregate base) + aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface + aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface + it "invalidates mapped-register snapshots when binding or wire identity changes" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro" + wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro" + let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) + aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint + + describe "process/timer (EP-3)" $ do + it "parses the hospital-surge process + nested timer" $ do + input <- readTestText "test/fixtures/hospital-surge.keiro" + case parseSpec "test/fixtures/hospital-surge.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [p | NProcess p <- specNodes spec] of + (p : _) -> do + procId p `shouldBe` "HospitalSurge" + procName p `shouldBe` "hospital-surge" + procRejected p `shouldBe` PolHalt + procPoison p `shouldBe` PolHalt + sagaCategory (procSaga p) `shouldBe` "hospitalSurge" + tmName (procTimer p) `shouldBe` "surgeFollowUp" + onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired + onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry + tmMaxAttempts (procTimer p) `shouldBe` 5 + [] -> expectationFailure "no process node parsed" + it "round-trips the hospital-surge spec through parse . pretty" $ do + input <- readTestText "test/fixtures/hospital-surge.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge.keiro" + codes `shouldBe` [] + it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + mapM_ + (\categoryName -> processErrorCodes (\process -> process{procSaga = (procSaga process){sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal]) + ["", "$all", "hospital-surge", "hospital surge", "wf:surge"] + source <- readTestText "test/fixtures/hospital-surge.keiro" + parseSpec "" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source) + `shouldSatisfy` isLeft + it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" + codes `shouldContain` [ProcessFireAtNotInjected] + it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" + length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1 + it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro" + codes `shouldContain` [ProcessDispatchIdSupplied] + it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro" + codes `shouldContain` [ProcessUnresolvedRef] + it "rejects unresolved process commands, projections, schedules, and advance ids" $ do + codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro" + length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5 + codes `shouldContain` [ProcessDispatchIdSupplied] + + describe "router (EP-108)" $ do + it "parses the incident-paging router shape" $ do + input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" + case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [router | NRouter router <- specNodes spec] of + [router] -> do + rtId router `shouldBe` "PagingRouter" + rtName router `shouldBe` "jitsurei-paging" + corrField (rtKey router) `shouldBe` "incidentId" + rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall" + rvRow (rtResolve router) `shouldBe` ["responderId"] + rdCommand (rtDispatch router) `shouldBe` "SendPage" + rtRejected router `shouldBe` PolDeadLetter + rtPoison router `shouldBe` PolHalt + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "round-trips the incident-paging spec through parse . pretty" $ do + input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the incident-paging router with warnings only" $ do + codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro" + codes `shouldBe` [] + diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro" + diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy] + it "rejects unresolved targets, keys, commands, and binding scopes" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + routerErrorCodes (\router -> router{rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef] + routerErrorCodes (\router -> router{rtKey = (rtKey router){corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown] + routerErrorCodes (\router -> router{rtDispatch = (rtDispatch router){rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown] + routerErrorCodes + ( \router -> + let dispatch = rtDispatch router + in router{rtDispatch = dispatch{rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}} + ) + spec + `shouldContain` [RouterBindingUnscoped] + it "rejects unresolved read models and contradictory rejection policies" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let withoutReadModel = removeReadModel "service_oncall" spec + errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef] + routerErrorCodes + ( \router -> + let dispatch = rtDispatch router + disposition = rdDisposition dispatch + in router + { rtRejected = PolHalt + , rtDispatch = dispatch{rdDisposition = disposition{onFailed = DDeadLetter "page rejected"}} + } + ) + spec + `shouldContain` [PolicyContradiction] + it "rejects on-ambiguous Fired for process timers" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + let changed = + spec + { specNodes = + [ case node of + NProcess process -> + let timer = procTimer process + fire = tmFire timer + disposition = fireDisposition fire + in NProcess process{procTimer = timer{tmFire = fire{fireDisposition = disposition{onAmbiguous = OFired}}}} + _ -> node + | node <- specNodes spec + ] + } + errorCodes changed `shouldContain` [AmbiguousMarkedBenign] + it "requires explicit policy and ambiguity clauses in the grammar" $ do + source <- readTestText "test/fixtures/hospital-surge.keiro" + parseSpec "" (T.replace " poison => halt\n" "" source) `shouldSatisfy` isLeft + parseSpec "" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft + it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> do + let ctx = defaultContext (specContext spec) + modules = scaffoldRouter ctx router + generated = [m | m <- modules, kind m == Generated] + holes = [m | m <- modules, kind m == HoleStub] + firewallBreaches generated `shouldBe` [] + case (generated, holes) of + ([generatedModule], [holeModule]) -> do + moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter" + moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities" + moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" + _ -> expectationFailure "expected one generated router module and one router hole module" + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "requires a caller callback for non-halting poison policies" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> do + let ctx = defaultContext (specContext spec) + generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated] + mapM_ + ( \(choice, constructor) -> case generatedFor choice of + [generatedModule] -> do + generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg" + generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback") + _ -> expectationFailure "expected one generated router module" + ) + [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")] + case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of + [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip" + _ -> expectationFailure "expected one generated router module" + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "emits router harness facts that pin policy and target-keyed identity" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> case harnessRouter (defaultContext (specContext spec)) router of + [facts] -> do + moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")" + moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence" + modules -> expectationFailure ("expected one router harness, got " <> show (length modules)) + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "rejects invalid timer ceilings and target field bindings" $ do + codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved] + it "accepts resolved process projection references" $ do + codes <- errorCodesOf "test/fixtures/surge-service.keiro" + codes `shouldBe` [] + it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do + mods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + let gens = [m | m <- mods, kind m == Generated] + holes = [m | m <- mods, kind m == HoleStub] + length holes `shouldBe` 1 + firewallBreaches gens `shouldBe` [] + case gens of + [generatedModule] -> do + -- the worker uses the spec's ceiling, never the dangerous default + moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\"" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)" + case holes of + [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory" + _ -> expectationFailure "expected one process hole module" + _ -> expectationFailure "expected one generated process module" + it "process scaffold is deterministic" $ do + a <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + b <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + map moduleText a `shouldBe` map moduleText b + + describe "contract (EP-4)" $ do + it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do + input <- readTestText "test/fixtures/contract.keiro" + case parseSpec "test/fixtures/contract.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [c | NContract c <- specNodes spec] of + (c : _) -> do + ctrName c `shouldBe` "emergency" + ctrDiscriminator c `shouldBe` "messageType" + map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"] + map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"] + [] -> expectationFailure "no contract node parsed" + it "round-trips the contract spec through parse . pretty" $ do + input <- readTestText "test/fixtures/contract.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "round-trips the intake (inbox) spec through parse . pretty" $ do + input <- readTestText "test/fixtures/intake.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the intake spec (complete disposition, no inversions)" $ do + codes <- errorCodesOf "test/fixtures/intake.keiro" + codes `shouldBe` [] + it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do + spec <- specOf "test/fixtures/intake.keiro" + ordinary <- specOf "test/fixtures/intake-decode.keiro" + case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of + ([intake], [defaultIntake]) -> do + inkPersist intake `shouldBe` InkPersistDedupeOnly + inkPersist defaultIntake `shouldBe` InkPersistFull + renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only" + renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist =" + let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake) + inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly" + (intakes, defaultIntakes) -> + expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes)) + it "rejects duplicate => retry (inversion 1)" $ do + codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro" + codes `shouldContain` [DispositionDuplicateRetry] + it "rejects previouslyFailed => retry (inversion 2)" $ do + codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro" + codes `shouldContain` [DispositionPreviouslyFailedRetry] + it "rejects an incomplete disposition table" $ do + codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro" + codes `shouldContain` [DispositionIncomplete] + it "rejects a shadowing duplicate intake disposition row" $ do + codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro" + codes `shouldContain` [DispositionDuplicateOutcome] + it "rejects intake events declared on another topic" $ do + codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro" + codes `shouldContain` [TopicAffinityMismatch] + it "round-trips the emit/publisher spec through parse . pretty" $ do + input <- readTestText "test/fixtures/emit.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do + codes <- errorCodesOf "test/fixtures/emit.keiro" + codes `shouldBe` [] + it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do + codes <- errorCodesOf "test/fixtures/emit-noskip.keiro" + codes `shouldContain` [EmitSkipMissing] + it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do + codes <- errorCodesOf "test/fixtures/emit-badevent.keiro" + codes `shouldContain` [EmitUnresolvedContract] + it "rejects emit events declared on another topic" $ do + codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro" + codes `shouldContain` [TopicAffinityMismatch] + + describe "pgmq workqueue/dispatch (EP-5)" $ do + it "round-trips the reservation-work spec through parse . pretty" $ do + input <- readTestText "test/fixtures/reservation-work.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the reservation-work spec (physical matches, no inversions)" $ do + codes <- errorCodesOf "test/fixtures/reservation-work.keiro" + codes `shouldBe` [] + it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro" + codes `shouldContain` [WqPhysicalDivergence] + it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro" + codes `shouldContain` [WqStoreFailureNotRetry] + it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro" + codes `shouldContain` [WqDecodeFailureNotDeadLetter] + it "requires complete, unique workqueue disposition rows" $ do + incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro" + incomplete `shouldContain` [WqDispositionIncomplete] + duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro" + let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome] + map line duplicateDiagnostics `shouldBe` [17] + it "checks the captured queueRef dlq and table fixtures" $ do + dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro" + dlqCodes `shouldContain` [WqDlqDivergence] + tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro" + tableCodes `shouldContain` [WqTableDivergence] + it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do + upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro" + upper `shouldBe` [] + hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro" + hashed `shouldBe` [] + derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments" + `shouldBe` ( "hospital_capacity_reservat_757040df00976c33" + , "hospital_capacity_reservat_757040df00976c33_dlq" + , "pgmq.q_hospital_capacity_reservat_757040df00976c33" + ) + it "resolves dispatch dedup queues and payload wire fields" $ do + ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro" + ghost `shouldContain` [DispatchDedupQueueUnresolved] + field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro" + field `shouldContain` [DispatchDedupFieldUnresolved] + it "requires a resolvable group key exactly when ordering is FIFO" $ do + noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro" + noKey `shouldContain` [WqGroupKeyMissing] + unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro" + unordered `shouldContain` [WqGroupKeyWithoutFifo] + source <- readTestText "test/fixtures/reservation-work.keiro" + unresolved <- parseInlineSpec "" (T.replace "group key from reservationId" "group key from missingId" source) + map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved] + it "warns on unlogged storage and rejects empty partition settings" $ do + warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro" + warningCodes `shouldContain` [WqUnloggedDurability] + partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro" + partitionCodes `shouldContain` [WqPartitionSpecEmpty] + it "lowers ordering, provisioning, and raw group-key projection" $ do + spec <- specOf "test/fixtures/reservation-work.keiro" + case [workqueue | NWorkqueue workqueue <- specNodes spec] of + workqueue : _ -> do + let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue + queue = generatedTextEndingIn "Queue.hs" modules + policy = generatedTextEndingIn "QueuePolicy.hs" modules + queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId" + policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput" + policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)" + firewallBreaches modules `shouldBe` [] + [] -> expectationFailure "reservation-work fixture has no workqueue" + + describe "readmodel (EP-107)" $ do + it "parses and round-trips first-class read models" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + [subscriptionModel, inlineModel] -> do + rmName subscriptionModel `shouldBe` "transfer_decisions" + rmColumns subscriptionModel + `shouldBe` [ RmColumn "reservation_id" "text" True + , RmColumn "hospital_id" "text" True + , RmColumn "status" "text" True + , RmColumn "decided_at" "timestamptz" False + ] + rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation") + rmFeed subscriptionModel `shouldBe` RmSubscription + rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub" + rmName inlineModel `shouldBe` "subscriptions" + rmScope inlineModel `shouldBe` Nothing + rmFeed inlineModel `shouldBe` RmInline + nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes)) + parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts an aggregate projection without a consistency clause" $ do + spec <- parseInlineSpec "" projectionWithoutConsistencySpec + case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of + [projection] -> projConsistency projection `shouldBe` Nothing + projections -> expectationFailure ("expected one projection, got " <> show (length projections)) + it "pins the canonical UTF-8 shape digest and runtime identities" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + (subscriptionModel : inlineModel : _) -> do + canonicalShape subscriptionModel + `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null" + deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6" + deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738" + registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions" + subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub" + subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub" + nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) + it "accepts the positive readmodel fixture with all references resolved" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + validateSpec spec `shouldBe` [] + it "rejects shape drift and unknown SQL column types" $ do + codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro" + codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType] + it "rejects Strong on inline and standalone projections" $ do + inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro" + inlineCodes `shouldContain` [RmStrongInlineOnly] + standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro" + let diagnostics = validateSpec standalone + map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode] + [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode] + `shouldBe` [Warning] + it "rejects scope without Strong and an unreferenced inline feed" $ do + scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro" + scopeCodes `shouldContain` [RmScopeWithoutStrong] + inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro" + inlineCodes `shouldContain` [RmInlineFeedUnreferenced] + it "rejects projection consistency conflicts" $ do + codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro" + codes `shouldContain` [RmConsistencyConflict] + it "resolves query read models and validates query consistency" $ do + codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro" + codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid] + it "resolves dispatch read models and declared dedup columns" $ do + codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro" + codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown] + it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + let ctx = defaultContext (specContext spec) + readModels = [readModel | NReadModel readModel <- specNodes spec] + modules = concatMap (scaffoldReadModel ctx) readModels + transfer = generatedTextEndingIn "Transfer_decisions/ReadModel.hs" modules + inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules + transferHoles = [moduleText m | m <- modules, "Transfer_decisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)] + length modules `shouldBe` 6 + length [m | m <- modules, kind m == Generated] `shouldBe` 4 + length [m | m <- modules, kind m == HoleStub] `shouldBe` 2 + firewallBreaches modules `shouldBe` [] + transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions" + transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]" + transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\"" + transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection" + inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []" + inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection" + transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()") + it "threads qualified table and column guidance into aggregate projection holes" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> do + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate + holes = [moduleText m | m <- modules, kind m == HoleStub] + projection = generatedTextEndingIn "Projection.hs" modules + holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable") + holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"") + projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable" + aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates)) + it "emits runtime-free derivation facts for each read model" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + (subscriptionModel : _) -> do + let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel + harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules + length modules `shouldBe` 1 + firewallBreaches modules `shouldBe` [] + harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", \"fnv1a:3717f6d9e3c44bd6\")" + harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", \"CategoryHead reservation\")" + harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts" + nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) + + describe "workflow/operation (EP-6)" $ do + it "round-trips the workflow spec through parse . pretty" $ do + input <- readTestText "test/fixtures/workflow.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the workflow spec (await<->signal matches, run resolves)" $ do + codes <- errorCodesOf "test/fixtures/workflow.keiro" + codes `shouldBe` [] + it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do + codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro" + codes `shouldContain` [AwaitSignalMismatch] + it "rejects duplicate workflow labels" $ do + codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro" + codes `shouldContain` [WorkflowDuplicateLabel] + it "rejects unresolved workflow id and sleep fields" $ do + codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro" + codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved] + it "validates rule domains, totality, case constructors, and bodies" $ do + unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro" + unresolved `shouldBe` [RuleDomainUnresolved] + codes <- errorCodesOf "test/fixtures/rule-not-total.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope] + it "rejects unresolved command operation references" $ do + codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro" + codes `shouldContain` [OperationUnresolvedRef] + it "rejects a signal value type that differs from its await" $ do + codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro" + codes `shouldContain` [AwaitSignalValueMismatch] + it "round-trips guarded patches and terminal continueAsNew" $ do + input <- readTestText "test/fixtures/workflow-evolution.keiro" + case parseSpec "workflow-evolution" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec + errorCodes spec `shouldBe` [] + it "rejects duplicate patch ids anywhere in the workflow body" $ do + codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro" + codes `shouldBe` [WorkflowPatchDuplicate] + it "rejects non-terminal and nested continueAsNew" $ do + codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro" + codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal] + it "rejects a colon in a patch id with a workflow diagnostic" $ do + codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro" + codes `shouldBe` [WorkflowPatchIdInvalid] + it "lowers patch facts and live runtime declarations" $ do + spec <- specOf "test/fixtures/workflow-evolution.keiro" + case [workflow | NWorkflow workflow <- specNodes spec] of + [workflow] -> do + let modules = harnessWorkflow (defaultContext (specContext spec)) workflow + facts = generatedTextEndingIn "WorkflowFacts.hs" modules + runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules + facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)" + facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed" + facts `shouldSatisfy` T.isInfixOf "(\"patches\", \"fraud-check-v2\")" + runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]" + runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}" + workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows)) + + describe "replay impact" $ do + it "treats new events and transitions as replay-neutral" $ do + old <- specOf "test/fixtures/reservation.keiro" + let aggregate = onlyAggregate old + case (aggEvents aggregate, aggTransitions aggregate) of + (event : _, transition : _) -> do + let newEvent = + event + { evName = "ReservationReviewed" + , evLoc = noLoc + } + newTransition = + transition + { tEmits = ["ReservationReviewed"] + , tLoc = noLoc + } + new = + modifyAggregate + "Reservation" + ( \candidate -> + candidate + { aggEvents = aggEvents candidate <> [newEvent] + , aggTransitions = aggTransitions candidate <> [newTransition] + } + ) + old + ReplayImpact.replayImpact old new `shouldBe` ReplayNeutral + _ -> expectationFailure "reservation fixture must contain an event and transition" + + it "narrows a guard edit to that transition's event types" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" + impact + `shouldBe` ReplayAffected + ( Map.singleton + "Reservation" + AggregateImpact + { eventTypes = Set.singleton "TransferReservationCreated" + , includeSnapshotStreams = True + } + ) + + it "proves a syntactic guard loosening replay-neutral" $ do + old <- specOf "test/fixtures/reservation.keiro" + let loosened = + modifyAggregate + "Reservation" + ( \aggregate -> + aggregate + { aggTransitions = + [ transition{tGuard = Nothing} + | transition <- aggTransitions aggregate + ] + } + ) + old + ReplayImpact.replayImpact old loosened `shouldBe` ReplayNeutral + + it "marks every existing event when the aggregate wire convention changes" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" + case impact of + ReplayAffected aggregates -> + ReplayImpact.eventTypes <$> Map.lookup "Reservation" aggregates + `shouldBe` Just (Set.fromList ["TransferReservationCreated", "TransferReservationConfirmed"]) + ReplayNeutral -> expectationFailure "expected a wire-clause replay impact" + + it "includes snapshot streams when a write expression changes" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" + case impact of + ReplayAffected aggregates -> + includeSnapshotStreams <$> Map.lookup "Reservation" aggregates + `shouldBe` Just True + ReplayNeutral -> expectationFailure "expected a fold replay impact" + + it "detects codec evolution and ignores formatting-only rewrites" $ do + changed <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" + changed `shouldSatisfy` (/= ReplayNeutral) + old <- specOf "test/fixtures/reservation.keiro" + formatted <- parseInlineSpec "" (renderSpec old) + ReplayImpact.replayImpact old formatted `shouldBe` ReplayNeutral + + it "names mapped nested event and snapshot roots while ignoring Haskell-only changes" $ do + nested <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" + case nested of + ReplayAffected aggregates -> + Map.lookup "Catalog" aggregates + `shouldBe` Just AggregateImpact{eventTypes = Set.singleton "ArtifactObserved", includeSnapshotStreams = True} + ReplayNeutral -> expectationFailure "expected nested mapped wire change to affect replay" + sourceOnly <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-haskell-rename.keiro" + sourceOnly `shouldBe` ReplayNeutral + + it "generates one context target for every aggregate, including the process saga" $ do + spec <- specOf "test/fixtures/surge-service.keiro" + case scaffoldReplayAudit (defaultContext (specContext spec)) spec of + [assembly] -> do + modulePath assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs" + moduleText assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream" + moduleText assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream" + T.count " AuditTarget" (moduleText assembly) `shouldBe` 2 + assemblies -> expectationFailure ("expected one replay-audit assembly, got " <> show (length assemblies)) + + describe "diff (evolution classification)" $ do + it "covers every node family exactly once and explains exclusions" $ do + sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily]) + [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` [] + it "derives every exercised headline from its vector under the default gate" $ do + changes <- + concat + <$> mapM + (uncurry diffFixtures) + [ ("test/fixtures/reservation.keiro", "test/fixtures/reservation-fieldadd.keiro") + , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-v2.keiro") + , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-enumadd.keiro") + , ("test/fixtures/contract.keiro", "test/fixtures/contract-fieldadd.keiro") + , ("test/fixtures/reservation-work.keiro", "test/fixtures/reservation-work-rename.keiro") + ] + forM_ changes $ \change -> + do + deriveLabel defaultGate (ckVector (kindOfChange change)) + `shouldBe` labelOfChange change + gatedBreaking defaultGate change `shouldBe` isBreaking change + it "never removes a breaking result when the gate grows" $ + property $ + forAll genCompatibilityVector $ \compatibility -> + forAll genSurfaceSet $ \gate -> + forAll genSurfaceSet $ \extra -> + deriveLabel gate compatibility + == LabelBreaking + ==> deriveLabel (gate <> extra) compatibility + == LabelBreaking + it "renders the consumer-neutral matrix with separate private, snapshot, and public surfaces" $ do + changes <- diffFixtures "test/fixtures/compatibility-vector-old.keiro" "test/fixtures/compatibility-vector-new.keiro" + golden <- readTestText "test/fixtures/compatibility-vector.diff.golden" + let rendered = T.intercalate "\n" (map renderFinding changes) + explained = T.intercalate "\n" (map renderExplainBlock changes) + reportJson = T.pack (show (Aeson.toJSON (diffReport defaultGate changes))) + T.stripEnd rendered `shouldBe` T.stripEnd golden + rendered `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" + rendered `shouldSatisfy` T.isInfixOf "old-binary-read-new-events=breaking" + rendered `shouldSatisfy` T.isInfixOf "snapshot-hydration=advisory" + rendered `shouldSatisfy` T.isInfixOf "public-consumer=breaking" + explained `shouldSatisfy` T.isInfixOf "invalidate and rebuild snapshots" + reportJson `shouldSatisfy` T.isInfixOf "keiro-dsl/diff-report/1" + reportJson `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" + let eventEnumFindings = + [ change + | change@(Advisory kind) <- changes + , ckCode kind == EnumCtorAdded + , verdictFor OldBinaryReadNewEvents (ckVector kind) == VBreaking + ] + eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate) + eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents])) + forM_ changes $ \change -> + remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) + `shouldSatisfy` (not . null) + it "rejects unknown --gate values with the valid surface list" $ do + parseSurfaceName "mystery-surface" + `shouldSatisfy` either (T.isInfixOf "old-binary-read-new-events" . T.pack) (const False) + it "covers the mapped evolution matrix with stable codes and non-empty remedies" $ do + let cases = + [ ("consumer-types-fieldadd-default.keiro", MappedFieldAddedWithDefault) + , ("consumer-types-fieldadd-nodefault.keiro", MappedFieldAddedNoDefault) + , ("consumer-types-fieldremove.keiro", MappedFieldRemoved) + , ("consumer-types-wirekey.keiro", MappedWireKeyChanged) + , ("consumer-types-haskell-rename.keiro", MappedHaskellSourceChanged) + , ("consumer-types-binding-change.keiro", MappedBindingChanged) + , ("consumer-types-fixtures-change.keiro", MappedFixturesChanged) + , ("consumer-types-initial-change.keiro", MappedInitialChanged) + , ("consumer-types-armadd.keiro", MappedArmAdded) + , ("consumer-types-tagchange.keiro", MappedArmTagChanged) + , ("consumer-types-enumadd.keiro", MappedEnumValueAdded) + , ("consumer-types-enumremove.keiro", MappedEnumValueRemoved) + , ("consumer-types-enumspelling.keiro", MappedEnumSpellingChanged) + , ("consumer-types-encoding.keiro", MappedUnionEncodingChanged) + , ("consumer-types-opaque-version.keiro", MappedOpaqueCodecChanged) + , ("consumer-types-mode-cross.keiro", MappedModeCrossed) + , ("consumer-types-nested-propagation.keiro", MappedArmTagChanged) + ] + forM_ cases $ \(fixture, expectedCode) -> do + changes <- diffFixtures "test/fixtures/consumer-types.keiro" ("test/fixtures/" <> fixture) + map (ckCode . kindOfChange) changes `shouldContain` [expectedCode] + forM_ changes $ \change -> + remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) + `shouldSatisfy` (not . null) + it "separates mapped event migration, snapshot invalidation, and directional rollout" $ do + breakingAdd <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-nodefault.keiro" + let noDefault = [change | change <- breakingAdd, ckCode (kindOfChange change) == MappedFieldAddedNoDefault] + [ckFacet kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"] + [ckFacet kind | Advisory kind <- noDefault] `shouldContain` ["mapped-register"] + defaulted <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-default.keiro" + [change | change <- defaulted, isBreaking change] `shouldBe` [] + let eventDefaults = [kind | Advisory kind <- defaulted, ckCode kind == MappedFieldAddedWithDefault, ckFacet kind == "mapped-event"] + eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) + armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro" + [change | change <- armAdded, isBreaking change] `shouldBe` [] + [kind | Advisory kind <- armAdded, ckCode kind == MappedArmAdded, ckFacet kind == "mapped-event"] + `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) + it "propagates a nested mapped leaf to complete command, event, and register paths" $ do + changes <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" + let subjects = + [ ckSubject kind + | change <- changes + , let kind = kindOfChange change + , ckCode kind == MappedArmTagChanged + ] + subjects + `shouldContain` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + ] + it "classifies every remaining mapped field and declaration evolution row" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + let mutationCodes = + [ (mapArtifactNamedField "key" (\field -> field{wfType = TInt}) base, MappedFieldTypeChanged) + , (mapArtifactNamedField "key" (\field -> field{wfPresence = POptional, wfOnMissing = Just (OmText "")}) base, MappedPresenceChanged) + , (mapArtifactNamedField "key" (\field -> field{wfType = TOptional TText}) base, MappedNullabilityChanged) + , (mapArtifactNamedField "description" (\field -> field{wfOnMissing = Nothing}) base, MappedDefaultRemoved) + , (mapArtifactNamedField "count" (\field -> field{wfOnMissing = Just (OmInt 1)}) base, MappedDefaultChanged) + , (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged) + , (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged) + ] + forM_ mutationCodes $ \(candidate, expectedCode) -> + map (ckCode . kindOfChange) (diffSpecs base candidate) `shouldContain` [expectedCode] + let declarationA = completeStructural "A" (recordShape [TText]) + declarationB = completeStructural "B" (recordShape [TInt]) + onlyA = mappedSpec [declarationA] + withB = mappedSpec [declarationA, declarationB] + map (ckCode . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded] + map (ckCode . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved] + diffSpecs base (mapArtifactNamedField "key" (\field -> field{wfHaskell = "renamedKey"}) base) + `shouldBe` [] + it "visits every mapped wire mutation and reports every complete root path" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + let mutations = mappedWireMutations base + mutations `shouldSatisfy` (not . null) + visited <- fmap Set.unions . forM mutations $ \mutation -> do + let changes = + [ change + | change <- diffSpecs base (mmCandidate mutation) + , ckCode (kindOfChange change) == mmCode mutation + ] + actualSubjects = Set.fromList (map (ckSubject . kindOfChange) changes) + changes `shouldSatisfy` any (not . isAdditiveChange) + actualSubjects `shouldBe` mmExpectedSubjects mutation + pure actualSubjects + visited `shouldBe` Set.unions (map mmExpectedSubjects mutations) + it "reports the exact ingredient code when every required mapped fact is deleted" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + forM_ (mappedIngredientMutations base) $ \(candidate, expectedCode) -> + errorCodes candidate `shouldContain` [expectedCode] + it "classifies a field added without a version bump as BREAKING" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro" + any isBreaking cs `shouldBe` True + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldAddedWithoutBump] + it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" + any isBreaking cs `shouldBe` False + [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject) + it "reports no breaking change when the spec is unchanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro" + any isBreaking cs `shouldBe` False + it "classifies a direct event field type change as EvtFieldTypeChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] + it "resolves fields(Command) before comparing event field types" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] + it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldRemovedSameVersion] + it "uses EvtVersionDecreased for a version decrease" $ do + cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionDecreased] + it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionMissingUpcaster] + it "classifies a vanished historical upcaster rung as UpcasterChainGap" $ do + cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation-chain-gap.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [UpcasterChainGap] + it "classifies an enum constructor removal as EnumCtorRemoved" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EnumCtorRemoved] + it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EnumWireSpellingChanged] + it "classifies an enum constructor addition per use site as advisory" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro" + any isBreaking cs `shouldBe` False + let enumFindings = [k | Advisory k <- cs, ckCode k == EnumCtorAdded] + [ckSubject k | k <- enumFindings] `shouldContain` ["BlackTag"] + [verdictFor SnapshotHydration (ckVector k) | k <- enumFindings] + `shouldContain` [VAdvisory] + it "classifies an effective wire convention change as WireSpecChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WireSpecChanged] + it "advises when the aggregate fold surface changes" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [AggFoldSurfaceChanged] + it "advises on hazardous deprecation and reports un-deprecation" $ do + deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro" + any isBreaking deprecated `shouldBe` False + [ckCode k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard] + restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro" + any isAdvisory restored `shouldBe` True + [ckCode k | Advisory k <- restored] `shouldContain` [EventUndeprecated] + it "recognises replay-only deprecation as a replay-safe retirement cutover" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated-replay-only.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] + [ckCode k | Advisory k <- cs] `shouldNotContain` [DeprecatedEventReplayHazard] + it "advises when event retirement starts" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-retiring.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] + it "does not recommend decode-only deprecation for an event removal" $ do + old <- specOf "test/fixtures/reservation.keiro" + let new = + old + { specNodes = + [ case node of + NAggregate aggregate -> + NAggregate + aggregate + { aggEvents = + [ event + | event <- aggEvents aggregate + , evName event /= "TransferReservationConfirmed" + ] + } + _ -> node + | node <- specNodes old + ] + } + removals = [change | change@(Breaking kind) <- diffSpecs old new, ckCode kind == EvtRemovedNotDeprecated] + removals `shouldSatisfy` (not . null) + [ckDetail kind | Breaking kind <- removals] + `shouldSatisfy` all (not . T.isInfixOf "so old payloads still decode") + it "prints a paste-ready replay-only twin when a guard tightens (plan 143)" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" + any isBreaking cs `shouldBe` False + let advisories = [k | Advisory k <- cs, ckCode k == AggGuardTightened] + map ckSubject advisories `shouldBe` ["Unrequested -- RequestTransferReservation"] + detail <- case advisories of + [k] -> pure (ckDetail k) + other -> expectationFailure ("expected one advisory, got " <> show other) >> pure "" + detail `shouldSatisfy` T.isInfixOf "replay-only Unrequested -- RequestTransferReservation" + -- The printed twin is paste-ready: appended to the new spec it + -- parses, validates without errors, and silences the advisory. + tightened <- readTestText "test/fixtures/reservation-guard-tightened.keiro" + let twinText = snd (T.breakOnEnd "\n\n" detail) + pasted = tightened <> "\n" <> twinText <> "\n" + case parseSpec "" pasted of + Left err -> expectationFailure (T.unpack err) + Right pastedSpec -> do + [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` [] + base <- specOf "test/fixtures/reservation.keiro" + [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened] + `shouldBe` [] + it "omits the twin advisory when the twin is already present (plan 143)" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro" + [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` [] + it "classifies a removed contract event as ContractEventRemoved" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved] + it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do + changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro" + [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged] + added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro" + [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged] + it "reports a field addition with a contract version bump as an advisory" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [ContractSchemaVersionBumped] + it "classifies a contract schema version decrease separately" $ do + cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ContractSchemaVersionDecreased] + it "classifies contract topic and discriminator changes separately" $ do + topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro" + [ckCode k | Breaking k <- topic] `shouldContain` [ContractTopicChanged] + discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro" + [ckCode k | Breaking k <- discriminator] `shouldContain` [ContractDiscriminatorChanged] + it "classifies a new contract event as additive" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"] + it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do + wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro" + [ckCode k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged] + fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro" + [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged] + required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro" + [ckCode k | Breaking k <- required] `shouldContain` [WqPayloadFieldChanged] + it "classifies a new optional workqueue payload field as additive" $ do + cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs] `shouldContain` ["note"] + it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqOrderingChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqOrderingChanged] + `shouldSatisfy` any (T.isInfixOf "delivery-order contract") + it "classifies workqueue provision changes as operational migrations" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqProvisionChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqProvisionChanged] + `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally") + it "classifies workqueue group-key changes as breaking repartitioning" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqGroupKeyChanged] + `shouldSatisfy` any (T.isInfixOf "re-partitioned") + it "classifies a process input type change as ProcessInputChanged" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ProcessInputChanged] + it "classifies workflow input and output changes as WorkflowShapeChanged" $ do + input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro" + [ckCode k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged] + output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro" + [ckCode k | Breaking k <- output] `shouldContain` [WorkflowShapeChanged] + it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do + relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro" + [ckCode k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged] + appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro" + [ckCode k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged] + [ckDetail k | Breaking k <- appended, ckCode k == WorkflowBodyChanged] + `shouldSatisfy` any (T.isInfixOf "new patch guard") + it "classifies a body addition wholly guarded by a new patch as additive" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"] + [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"] + it "classifies removing an existing patch as breaking" $ do + cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved] + [ckDetail k | Breaking k <- cs, ckCode k == WorkflowPatchRemoved] + `shouldSatisfy` any (T.isInfixOf "cannot prove") + it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do + appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro" + any isBreaking appended `shouldBe` False + [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"] + changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro" + [ckCode k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged] + [ckDetail k | Breaking k <- changed, ckCode k == WorkflowContinueSeedChanged] + `shouldSatisfy` any (T.isInfixOf "restoreSeed") + it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowStableNameChanged] + it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [DerivedIdentityChanged] + it "classifies an id prefix change as IdPrefixChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [IdPrefixChanged] + it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do + policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro" + [ckCode k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged] + key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro" + [ckCode k | Breaking k <- key] `shouldContain` [DedupeIdentityChanged] + it "reports intake decode-posture changes as warnings" $ do + cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [DecodePostureChanged] + [ckCode k | Advisory k <- cs] `shouldContain` [IntakePersistenceChanged] + it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do + processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro" + [ckCode k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged] + timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro" + [ckCode k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged] + base <- specOf "test/fixtures/hospital-surge.keiro" + let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process{procSaga = (procSaga process){sagaCategory = "hospitalSurgeV2"}}) base) + [ckCode k | Breaking k <- categoryChange] `shouldContain` [DerivedIdentityChanged] + it "classifies router stable names, keys, and targets as identity-bearing" $ do + base <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtName = "paging-v2"}) base) + keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtKey = (rtKey router){corrVia = "otherIdText"}}) base) + target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtTarget = "OtherPage"}) base) + [ckCode k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged] + [ckCode k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged] + [ckCode k | Breaking k <- target] `shouldContain` [DerivedIdentityChanged] + it "advises on router dispatch-surface changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/incident-paging/incident-paging.keiro" "test/fixtures/incident-paging/incident-paging-dispatch.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [RouterDecideSurfaceChanged] + it "advises on process dispatch-surface changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-handle.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [ProcessDecideSurfaceChanged] + it "advises on unversioned timer payload changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-payload.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [ProcessTimerPayloadChanged] + it "ignores formatting-only process and timer surface rewrites" $ do + original <- specOf "test/fixtures/hospital-surge.keiro" + formatted <- parseInlineSpec "" (renderSpec original) + diffSpecs original formatted `shouldBe` [] + it "reports a timer window change as a warning" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [TimerWindowChanged] + it "reports emit-map changes as warnings and derive changes as breaking" $ do + mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro" + any isBreaking mapping `shouldBe` False + [ckCode k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged] + derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro" + [ckCode k | Breaking k <- derive] `shouldContain` [DerivedIdentityChanged] + it "classifies publisher outbox identity and ordering independently" $ do + outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro" + [ckCode k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged] + ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro" + any isBreaking ordering `shouldBe` False + [ckCode k | Advisory k <- ordering] `shouldContain` [PublisherPolicyChanged] + it "classifies workqueue names as QueueIdentityChanged" $ do + cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [QueueIdentityChanged] + it "classifies pgmq dispatch dedupe and retargeting independently" $ do + dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro" + [ckCode k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged] + retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro" + any isBreaking retarget `shouldBe` False + [ckCode k | Advisory k <- retarget] `shouldContain` [DispatchRetargeted] + it "reports aggregate projection changes as warnings" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [ProjectionChanged] + it "classifies read-model version and unversioned shape changes" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmVersion = 2}) base + changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base + bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel){rmVersion = 2}) base + decreased = diffSpecs versionTwo base + unversioned = diffSpecs base changedShape + bumped = diffSpecs base bumpedShape + [ckCode k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased] + [ckCode k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump] + any isBreaking bumped `shouldBe` False + [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"] + it "classifies read-model registry, table, subscription, and removal identities" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmTable = "transfer_decisions_v2"}) base + subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmSubscription = Just "transfer-decisions-v2"}) base + renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmName = "reservation_decisions"}) base + removed = removeReadModel "transfer_decisions" base + mapM_ + (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [DerivedIdentityChanged]) + [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed] + it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmFeed = RmInline}) base + consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) base + entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmScope = Just RmEntireLog}) base + [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged] + [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened] + [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [ReadModelConsistencyWeakened] + it "classifies Eventual to Strong read-model consistency as additive" $ do + strong <- specOf "test/fixtures/readmodel-runtime.keiro" + let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) strong + changes = diffSpecs eventual strong + any isBreaking changes `shouldBe` False + [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"] + + describe "module placement (M1)" $ do + it "GeneratedPrefix is today's namespace (Generated.., holes at .)" $ do + let ctx = defaultContext "hospital-capacity" + genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation" + holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation" + it "module-root prefixes both layers" $ do + let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"} + genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation" + holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" + it "CollocatedLeaf places the generated layer under the domain leaf" $ do + let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf} + genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated" + holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" + it "parses and preserves the module/layout clauses through parse . pretty" $ do + let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n regs\n states Open\n" + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specModuleRoot spec `shouldBe` Just "Acme.Services" + specLayout spec `shouldBe` Just CollocatedLeaf + parseSpec "" (renderSpec spec) `shouldBe` Right spec + it "a spec without the clauses leaves placement at the default" $ do + input <- readTestText "test/fixtures/reservation.keiro" + case parseSpec "test/fixtures/reservation.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specModuleRoot spec `shouldBe` Nothing + specLayout spec `shouldBe` Nothing + + describe "structural scaffold" $ do + it "emits one private shape module per structural declaration and one context facade" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + paths = map modulePath modules + paths + `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs" + , "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs" + , "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs" + , "Generated/ConsumerDemo/StructuralProjections.hs" + ] + paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"] + firewallBreaches modules `shouldBe` [] + it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"] + shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules + case skeletons of + [skeleton] -> do + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key" + _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons)) + shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)" + shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)" + it "never overwrites an existing binding skeleton" $ + withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + bindingPath = out "Example/Artifact/KeiroBindings.hs" + _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec + TIO.writeFile bindingPath "hand-owned binding\n" + second <- executePlannedScaffold out "consumer-types.keiro" ctx spec + TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n" + reportDispositions second + `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped) + it "fresh binding skeletons compile at the application boundary" $ + withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do + spec <- specOf "test/fixtures/structural-conformance.keiro" + let ctx = defaultContext (specContext spec) + bindingSource = out "Conformance/Structural/Bindings.hs" + ghcOutput = out ".ghc" + _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec + createDirectoryIfMissing True ghcOutput + (exitCode, standardOutput, standardError) <- + readProcessWithExitCode + "cabal" + [ "exec" + , "--" + , "ghc" + , "-XGHC2024" + , "-XOverloadedStrings" + , "-fno-code" + , "-fforce-recomp" + , "-outputdir" + , ghcOutput + , "-i" <> out + , "-itest/conformance-structural" + , "-i../keiro-core/src" + , bindingSource + ] + "" + unless (exitCode == ExitSuccess) $ + expectationFailure (standardOutput <> standardError) + it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + domain = generatedTextEndingIn "Catalog/Domain.hs" modules + codec = generatedTextEndingIn "Catalog/Codec.hs" modules + domain `shouldSatisfy` T.isInfixOf "Example.Artifact.Domain.ArtifactInfo" + domain `shouldSatisfy` T.isInfixOf "Vendor.Geometry.Geometry" + domain `shouldSatisfy` T.isInfixOf "Example.Artifact.KeiroBindings.emptyArtifactInfo" + codec `shouldSatisfy` T.isInfixOf "\"location\" .= encodeArtifactLocationShape" + codec `shouldSatisfy` T.isInfixOf "\"local_file\"" + codec `shouldSatisfy` T.isInfixOf "Nothing -> pure Generated.ConsumerDemo.Structural.Shape.ArtifactKind.Guide" + codec `shouldSatisfy` T.isInfixOf "rejectUnknownFields \"ArtifactInfo\"" + codec `shouldSatisfy` T.isInfixOf "toJSON payload.geometry" + codec `shouldSatisfy` (not . T.isInfixOf "vendor.geometry.json") + it "generates shape-only nested types and schema-derived Keiki witnesses" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules + facade = generatedTextEndingIn "StructuralProjections.hs" modules + shape `shouldSatisfy` T.isInfixOf "data ArtifactInfoShape = ArtifactInfo" + shape `shouldSatisfy` T.isInfixOf "ArtifactKind.ArtifactKindShape" + shape `shouldSatisfy` (not . T.isInfixOf "KeiroBindings") + facade `shouldSatisfy` T.isInfixOf "type FieldName" + facade `shouldSatisfy` T.isInfixOf "= \"/key\"" + facade `shouldSatisfy` T.isInfixOf "fieldShapeId _ = \"example.artifact.ArtifactInfo.v1\"" + facade `shouldSatisfy` T.isInfixOf "bindingToShape Example.Artifact.KeiroBindings.artifactInfoBinding owner" + + describe "structural manifest" $ do + it "lists consumer packages and every domain, binding, fixture, and initial module" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + manifest = renderManifest "consumer-types.keiro" modules spec + mapM_ (\packageName -> manifestDependencies spec `shouldContain` [packageName]) ["artifact-domain", "vendor-geometry"] + manifest `shouldSatisfy` T.isInfixOf "consumer-packages:\n artifact-domain\n vendor-geometry" + mapM_ + (\moduleName -> manifest `shouldSatisfy` T.isInfixOf moduleName) + [ "Example.Artifact.Domain" + , "Example.Artifact.KeiroBindings" + , "Vendor.Geometry" + , "Vendor.Geometry.KeiroBindings" + ] + + describe "structural scaffold record" $ do + it "round-trips canonical mapping rows and reports binding drift on the next run" $ + withTempDirectory "keiro-dsl-mapping-record" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + first <- executePlannedScaffold out "consumer-types.keiro" ctx spec + length (consumerMappings (reportConsumerPlan first)) `shouldBe` 4 + recordText <- TIO.readFile (out recordFileName (specContext spec)) + let mappingRows = filter (T.isPrefixOf "mapping ") (T.lines recordText) + bindingRows = filter (T.isPrefixOf "binding ") (T.lines recordText) + length mappingRows `shouldBe` 4 + bindingRows `shouldSatisfy` (not . null) + fmap recMappings (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length) + fmap recBindingObligations (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length) + let bumped = spec{specMapped = map bumpArtifactBindingVersion (specMapped spec)} + second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped + reportMappingDrift second + `shouldSatisfy` any (\drift -> driftSpecName drift == "ArtifactInfo" && driftPrevious drift /= driftCurrent drift) + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "mapping drift:") + case mappingRows of + row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing + [] -> expectationFailure "expected mapping rows" + case bindingRows of + row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing + [] -> expectationFailure "expected binding rows" + it "reports exactly the newly added binding field without rewriting the shared skeleton" $ + withTempDirectory "keiro-dsl-binding-drift" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec + let extended = spec{specMapped = map addArtifactSummaryField (specMapped spec)} + second <- executePlannedScaffold out "consumer-types.keiro" ctx extended + reportNewHoles second + `shouldBe` [ BindingHole + { holeMappedName = "ArtifactInfo" + , holeModule = "Example.Artifact.KeiroBindings" + , holeSymbol = "artifactInfoBinding" + , holeKind = BindingValue + , holePath = Just "summary" + , holeSignature = "artifactInfoBinding.summary :: Text" + } + ] + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "artifactInfoBinding.summary :: Text") + it "rejects malformed known mapping JSON while ignoring unrelated future rows" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + withTempDirectory "keiro-dsl-mapping-malformed" $ \out -> do + report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec + recordText <- TIO.readFile (reportRecordPath report) + parseRecord (recordText <> "mapping {not-json}\n") `shouldBe` Nothing + parseRecord (recordText <> "future-row retained\n") `shouldBe` parseRecord recordText + + describe "structural import plan" $ do + it "reports the successful dependency plan in the scaffold report" $ + withTempDirectory "keiro-dsl-dependency-plan" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec + renderScaffoldReport report + `shouldSatisfy` any (T.isInfixOf "dependency plan: consumer packages [artifact-domain, vendor-geometry]") + it "refuses a binding module inside the generated namespace with the exact cycle" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let cyclic = spec{specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)} + case planScaffold (defaultContext (specContext cyclic)) cyclic of + Left refusals -> do + refusals `shouldSatisfy` any isImportCycle + renderRefusals refusals `shouldSatisfy` any (T.isInfixOf "Generated.ConsumerDemo.Bindings") + Right _ -> expectationFailure "expected an import-cycle refusal" + it "refuses missing mapped register initials but permits command/event-only use" $ do + missing <- specOf "test/fixtures/mapped-missing-initial.keiro" + planScaffold (defaultContext (specContext missing)) missing `shouldSatisfy` isLoweringRefusal + spec <- specOf "test/fixtures/consumer-types.keiro" + let commandOnly = removeMappedRegisterRequirements spec + planScaffold (defaultContext (specContext commandOnly)) commandOnly `shouldSatisfy` isRight + + describe "binding explanations" $ do + it "lists binding, fixture, and use-site-scoped initial obligations deterministically" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) + length obligations `shouldBe` 7 + obligations + `shouldSatisfy` any + ( \obligation -> + obligationKind obligation == BindingValue + && obligationSymbol obligation == "artifactInfoBinding" + && obligationBindingVersion obligation == Just "1" + ) + obligations + `shouldSatisfy` any + ( \obligation -> + obligationKind obligation == InitialValue + && obligationSymbol obligation == "emptyArtifactInfo" + && any (T.isInfixOf "Catalog register currentArtifact") (obligationUseSites obligation) + ) + let rendered = renderBindingObligations (specContext spec) obligations + rendered `shouldSatisfy` T.isInfixOf "binding obligations for context consumer-demo" + rendered `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding Example.Artifact.Domain.ArtifactInfo ArtifactInfoShape" + rendered `shouldSatisfy` T.isInfixOf "provenance: binding-version \"1\"" + it "states explicitly when a spec has no structural obligations" $ do + spec <- specOf "test/fixtures/reservation.keiro" + obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) + renderBindingObligations (specContext spec) obligations + `shouldBe` "no binding obligations for context hospital-capacity" + + describe "exact generic structural bindings" $ do + forM_ + [ ("renamed-field", "selector mismatch") + , ("reordered-field", "selector mismatch") + , ("arity-mismatch", "no exact nominal correspondence") + , ("incompatible-type", "no exact nominal correspondence") + ] + $ \(fixture, diagnostic) -> + it ("rejects " <> fixture <> " and directs the author to the scaffolded module") $ + expectGenericCompileFailure fixture diagnostic + + describe "structural harness" $ do + it "emits every structural, wire-policy, projection, and replay assertion family" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let aggregate = onlyAggregate spec + ctx = defaultContext (specContext spec) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) + mapM_ + (\needle -> harness `shouldSatisfy` T.isInfixOf needle) + [ "binding domain round-trip: example.artifact.ArtifactInfo.v1/" + , "binding shape round-trip: example.artifact.ArtifactInfo.v1/" + , "mapped codec round-trip: ArtifactObserved/artifact/" + , "fixture coverage: example.artifact.ArtifactLocation.v1" + , "wire policy missing default: example.artifact.ArtifactInfo.v1/description" + , "wire policy explicit null: example.artifact.ArtifactInfo.v1/description" + , "wire policy unknown fields: example.artifact.ArtifactInfo.v1" + , "wire union arm: example.artifact.ArtifactLocation.v1/local_file" + , "canonical identity: example.artifact.ArtifactInfo.v1" + , "projection witness agreement: example.artifact.ArtifactInfo.v1/key" + , "forward/replay equality: ObserveArtifact from CatalogEmpty -- " + , "register currentArtifact" + ] + it "keeps opaque assertions at the declared codec boundary" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let aggregate = onlyAggregate spec + ctx = defaultContext (specContext spec) + modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate + harness = generatedTextEndingIn "Harness.hs" modules + codec = generatedTextEndingIn "Codec.hs" modules + harness `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/" + harness `shouldNotSatisfy` T.isInfixOf "wire policy unknown fields: vendor.geometry.json" + harness `shouldNotSatisfy` T.isInfixOf "fixture coverage: vendor.geometry" + codec `shouldNotSatisfy` T.isInfixOf "encodeVendorGeometryShape" + + describe "manifest (M2)" $ do + it "lists exactly the modules the scaffolder produced" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + spec <- specOf "test/fixtures/reservation.keiro" + let manifest = renderManifest "reservation.keiro" mods spec + expectedNames = sort (map (moduleNameOf . modulePath) mods) + -- every produced module name appears in the manifest… + mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames + -- …and the module list is exactly the scaffolder's output set. + expectedNames + `shouldBe` sort + [ "Generated.HospitalCapacity.Reservation.Codec" + , "Generated.HospitalCapacity.Reservation.Domain" + , "Generated.HospitalCapacity.Reservation.EventStream" + , "Generated.HospitalCapacity.Reservation.Harness" + , "Generated.HospitalCapacity.Reservation.Projection" + , "HospitalCapacity.Reservation.Holes" + ] + it "derives the dependency set from the node kinds present (aggregate)" $ do + spec <- specOf "test/fixtures/reservation.keiro" + manifestDependencies spec `shouldBe` ["aeson", "base", "keiki", "keiro", "text"] + it "derives the process dependency set, including worker-policy runtime imports" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + let dependencies = manifestDependencies spec + mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"] + it "uses the registered shibuya-core package name for router scaffolds" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let dependencies = manifestDependencies spec + mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"] + dependencies `shouldNotContain` ["shibuya"] + + describe "new skeletons (M5)" $ do + it "every skeleton parses and validates with zero error diagnostics" $ + mapM_ assertSkeletonValid skeletonKinds + it "every skeleton passes the scaffold refusal gates" $ + mapM_ assertSkeletonScaffoldable skeletonKinds + it "fresh skeleton scaffolds match the committed compiling modules" $ + mapM_ (uncurry assertSkeletonMatchesCommitted) skeletonModuleRoots + it "rejects an unknown kind with a helpful message" $ + case skeletonFor "bogus" of + Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True + Right _ -> expectationFailure "expected an error for an unknown kind" + + describe "firewall self-check (M3)" $ do + it "flags a forbidden operator in a Generated module" $ do + let m = ScaffoldModule{modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"} + firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)] + it "ignores forbidden operators in a HoleStub module (holes own them)" $ do + let m = ScaffoldModule{modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"} + firewallBreaches [m] `shouldBe` [] + it "matches `lit` as a word, not a substring of quality/split" $ do + let clean = ScaffoldModule{modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"} + dirty = ScaffoldModule{modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"} + firewallBreaches [clean] `shouldBe` [] + firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)] + it "skips strings and comments and maximal-munches symbolic tokens" $ do + let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b" + dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d" + firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)] + firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)] + it "guards keiki imports while allowing the generated Core allowlist" $ do + let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder" + restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)" + allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)" + firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)] + firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)] + firewallBreaches [allowed] `shouldBe` [] + it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do + aggMods <- scaffoldFixture "test/fixtures/reservation.keiro" + procMods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + firewallBreaches (aggMods <> procMods) `shouldBe` [] + + describe "scaffold gates" $ do + it "refuses duplicate and case-folded module paths with both origins" $ do + spec <- specOf "test/fixtures/reservation.keiro" + case [aggregate | NAggregate aggregate <- specNodes spec] of + aggregate : _ -> do + let duplicate = spec{specNodes = [NAggregate aggregate, NAggregate aggregate]} + caseVariant = spec{specNodes = [NAggregate aggregate, NAggregate aggregate{aggName = T.toUpper (aggName aggregate)}]} + planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins + planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins + [] -> expectationFailure "reservation fixture has no aggregate" + it "refuses a bannerless Generated target without changing its bytes" $ + withTempDirectory "keiro-dsl-banner" $ \out -> do + spec <- specOf "test/fixtures/reservation.keiro" + let ctx = defaultContext (specContext spec) + case planScaffold ctx spec of + Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals) + Right modules -> case [m | m <- modules, kind m == Generated] of + generated : _ -> do + let target = out modulePath generated + createDirectoryIfMissing True (takeDirectory target) + TIO.writeFile target "hand owned\n" + result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules + result `shouldSatisfy` isMissingBannerRefusal + TIO.readFile target `shouldReturn` "hand owned\n" + forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules + forced `shouldSatisfy` isSuccessfulScaffold + TIO.readFile target `shouldReturn` moduleText generated + [] -> expectationFailure "reservation scaffold has no Generated module" + it "reports renamed-node modules as stale without deleting them" $ + withTempDirectory "keiro-dsl-stale-rename" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec + let renamed = spec{specNodes = map renameCounter (specNodes spec)} + second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed + let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first)) + oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first)) + reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `elem` stale && StaleModule HoleStub oldHoles `elem` stale + doesFileExist (out oldDomain) `shouldReturn` True + doesFileExist (out oldHoles) `shouldReturn` True + it "reports the entire old tree across a module-root flip" $ + withTempDirectory "keiro-dsl-stale-root" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let initialCtx = defaultContext (specContext spec) + rootedCtx = initialCtx{moduleRoot = "Acme"} + first <- executePlannedScaffold out "counter.keiro" initialCtx spec + second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec + reportStale second + `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first] + forM_ (reportStale second) $ \stale -> doesFileExist (out stalePath stale) `shouldReturn` True + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro") + it "reports moved generated modules across a layout flip" $ + withTempDirectory "keiro-dsl-stale-layout" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let initialCtx = defaultContext (specContext spec) + collocatedCtx = initialCtx{placement = CollocatedLeaf} + first <- executePlannedScaffold out "counter.keiro" initialCtx spec + second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec + let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated] + reportStale second `shouldSatisfy` all (`elem` oldGenerated) + length (reportStale second) `shouldBe` length oldGenerated + it "writes a parseable record and no stale section for a fresh output" $ + withTempDirectory "keiro-dsl-record" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let ctx = defaultContext (specContext spec) + report <- executePlannedScaffold out "counter.keiro" ctx spec + reportStale report `shouldBe` [] + renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:") + contents <- TIO.readFile (out recordFileName (specContext spec)) + parseRecord contents + `shouldBe` Just + ScaffoldRecord + { recSpecPath = "counter.keiro" + , recModuleRoot = "" + , recLayout = "prefixed" + , recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report] + , recMappings = [] + , recBindingObligations = [] + } + parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents + parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing + + describe "faithful scaffold lowering" $ do + it "escapes a trailing-backslash payload literal exactly once" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + case [process | NProcess process <- specNodes spec] of + process : _ -> do + let timer = (procTimer process){tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]} + modules = scaffoldProcess (defaultContext (specContext spec)) process{procTimer = timer} + generatedTextEndingIn "Process.hs" modules + `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)" + [] -> expectationFailure "hospital-surge fixture has no process" + it "preserves quoted Text register initials and refuses unsafe register shapes" $ do + spec <- parseInlineSpec "" loweringAggregateSpec + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec] + domain = generatedTextEndingIn "Domain.hs" modules + domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\"" + scaffoldRefusals spec `shouldBe` [] + bare <- parseInlineSpec "" (T.replace "\"hello world\"" "hello" loweringAggregateSpec) + scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted") + unsupported <- parseInlineSpec "" (T.replace "count:Int" "count:Time" loweringAggregateSpec) + scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable") + it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do + windowSeconds "90s" `shouldBe` Right 90 + windowSeconds "5m" `shouldBe` Right 300 + windowSeconds "2h" `shouldBe` Right 7200 + emitSource <- readTestText "test/fixtures/emit.keiro" + let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource + exponential <- parseInlineSpec "" exponentialSource + case [publisher | NPublisher publisher <- specNodes exponential] of + publisher : _ -> do + let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher) + generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }" + parseSpec "" (renderSpec exponential) `shouldBe` Right exponential + [] -> expectationFailure "emit fixture has no publisher" + constant <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource) + case [publisher | NPublisher publisher <- specNodes constant] of + publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120" + [] -> expectationFailure "emit fixture has no publisher" + it "refuses incomplete exponential backoff and rejects unknown window units" $ do + emitSource <- readTestText "test/fixtures/emit.keiro" + incomplete <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource) + scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete") + parseSpec "" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource) + `shouldSatisfy` leftContains "time unit: s, m, or h" + it "lowers workqueue retry windows in minutes to seconds" $ do + queueSource <- readTestText "test/fixtures/reservation-work.keiro" + queueSpec <- parseInlineSpec "" (T.replace "5s" "5m" queueSource) + case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of + workqueue : _ -> do + let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue) + policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300" + policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)" + [] -> expectationFailure "queue fixture has no workqueue" + it "uses exact status-map keys and emits total Int harness samples" $ do + statusSpec <- parseInlineSpec "" exactStatusSpec + case [aggregate | NAggregate aggregate <- specNodes statusSpec] of + aggregate : _ -> do + let ctx = defaultContext (specContext statusSpec) + projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate) + projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\"" + harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0" + harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported" + [] -> expectationFailure "exact-status spec has no aggregate" + + describe "scaffold" $ do + it "synthesizes the exact old wire shape and embeds it in the harness" $ do + oldSpec <- specOf "test/fixtures/reservation.keiro" + newSpec <- specOf "test/fixtures/reservation-v2.keiro" + case goldensForDiff oldSpec newSpec of + [golden] -> do + goldenRelativePath golden + `shouldBe` "hospital-capacity/Reservation/TransferReservationCreated.v1.json" + goldenJson golden + `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n" + goldenEvidence golden `shouldBe` SynthesizedWeakStandIn + let aggregate = onlyAggregate newSpec + modules = + harnessForWithGoldens + [golden] + (defaultContext (specContext newSpec)) + newSpec + aggregate + harness = generatedTextEndingIn "Harness.hs" modules + harness `shouldSatisfy` T.isInfixOf "golden TransferReservationCreated.v1 decodes" + harness `shouldSatisfy` T.isInfixOf "\\\"reservationId\\\":\\\"rsv_" + harness `shouldSatisfy` (not . T.isInfixOf "current-shape stand-in") + goldens -> expectationFailure ("expected one synthesized golden, got " <> show goldens) + it "synthesizes complete nested mapped old shapes deterministically and never overwrites captured evidence" $ do + oldSpec <- specOf "test/fixtures/consumer-types.keiro" + newSpec <- specOf "test/fixtures/consumer-types-v2.keiro" + case goldensForDiff oldSpec newSpec of + [golden] -> do + goldenEvidence golden `shouldBe` SynthesizedWeakStandIn + goldenJson golden `shouldSatisfy` T.isInfixOf "\"artifact\":{" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"revision\":1" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"observedAt\":\"2026-01-01T00:00:00Z\"" + goldensForDiff oldSpec newSpec `shouldBe` [golden] + withTempDirectory "keiro-golden-preserve" $ \root -> do + let target = root goldenRelativePath golden + createDirectoryIfMissing True (takeDirectory target) + TIO.writeFile target "hand captured\n" + emitGoldenPayloads root oldSpec newSpec `shouldReturn` [] + TIO.readFile target `shouldReturn` "hand captured\n" + withTempDirectory "keiro-golden-write" $ \root -> do + let target = root goldenRelativePath golden + emitGoldenPayloads root oldSpec newSpec `shouldReturn` [target] + TIO.readFile target `shouldReturn` goldenJson golden + goldens -> expectationFailure ("expected one nested synthesized golden, got " <> show goldens) + it "dispatches shared-version upcasters by wire event type and passes foreign kinds through" $ do + source <- readTestText "test/fixtures/reservation-dup-upcast-source.keiro" + spec <- parseInlineSpec "" source + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> do + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate + codec = generatedTextEndingIn "Codec.hs" modules + holes = case [moduleText m | m <- modules, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] of + [text] -> text + _ -> "" + codec `shouldSatisfy` T.isInfixOf "upcasters = [(1, upcastRungV1)]" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationCreated\") value = upcastTransferReservationCreatedV1 value" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationConfirmed\") value = upcastTransferReservationConfirmedV1 value" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 _ value = Right value" + holes `shouldSatisfy` T.isInfixOf "receives ONLY TransferReservationCreated payloads" + _ -> expectationFailure "expected exactly one aggregate" + it "keeps foreign payloads byte-for-byte and invokes both same-rung event upcasters" $ do + let payloadA = object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (2 :: Int)] + payloadB = object ["kind" .= ("AmountRenamed" :: T.Text), "amount" .= (3 :: Int)] + foreignPayload = object ["kind" .= ("AmountObserved" :: T.Text), "amount" .= (7 :: Int)] + upcastA _ = Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) + upcastB _ = Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) + rung (EventType "AmountScaled") = upcastA + rung (EventType "AmountRenamed") = upcastB + rung _ = Right + codec = + Codec + { eventTypes = EventType "AmountScaled" :| [EventType "AmountRenamed", EventType "AmountObserved"] + , eventType = const (EventType "AmountObserved") + , schemaVersion = 2 + , encode = id + , decode = \_ -> Right + , upcasters = [(1, rung)] + } :: + Codec Value + decodeRaw codec (EventType "AmountObserved") 1 foreignPayload `shouldBe` Right foreignPayload + decodeRaw codec (EventType "AmountScaled") 1 payloadA + `shouldBe` Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) + decodeRaw codec (EventType "AmountRenamed") 1 payloadB + `shouldBe` Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) + it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + firewallBreaches mods `shouldBe` [] + it "marks the Holes module HoleStub and the rest Generated" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + let holes = [m | m <- mods, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] + map kind holes `shouldBe` [HoleStub] + -- Domain, Codec, EventStream, Projection, Harness. + length [m | m <- mods, kind m == Generated] `shouldBe` 5 + it "is deterministic (re-scaffolding yields byte-identical text)" $ do + a <- scaffoldFixture "test/fixtures/reservation.keiro" + b <- scaffoldFixture "test/fixtures/reservation.keiro" + map moduleText a `shouldBe` map moduleText b + it "keeps retiring as validator-only metadata in generated modules" $ do + ordinary <- scaffoldFixture "test/fixtures/reservation.keiro" + retiring <- scaffoldFixture "test/fixtures/reservation-retiring.keiro" + map (\m -> (modulePath m, kind m, moduleText m)) retiring + `shouldBe` map (\m -> (modulePath m, kind m, moduleText m)) ordinary + it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated] + it "matches every committed new-surface Generated module (modulo formatting)" $ do + spec <- specOf "test/fixtures/transfer-routing.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + forM_ [m | m <- modules, kind m == Generated] $ \m -> do + committed <- readTestText ("test/conformance-newsurface/" <> modulePath m) + normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) + it "scaffolds the register-free OrderStream smoke target without error" $ do + mods <- scaffoldFixture "test/fixtures/order.keiro" + -- 5 Generated (Domain/Codec/EventStream/Projection/Harness) + 1 Holes. + length mods `shouldBe` 6 + firewallBreaches mods `shouldBe` [] + let harness = generatedTextEndingIn "Harness.hs" mods + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: PlaceOrder from OrderNotStarted -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"final vertex\"" + harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register " + it "emits forward/replay checks with field-distinct Text samples" $ do + spec <- parseInlineSpec "" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec) + case [aggregate | NAggregate aggregate <- specNodes spec] of + aggregate : _ -> do + let ctx = defaultContext (specContext spec) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) + harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\"" + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\"" + [] -> expectationFailure "forward/replay sample spec has no aggregate" + it "emits the canonical reservation register checks" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + let harness = generatedTextEndingIn "Harness.hs" mods + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: RequestTransferReservation from ReservationUnrequested -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"register reservationState\"" + it "lowers a replay-only transition to B.replayOnly in the holes skeleton (plan 143)" $ do + twinMods <- scaffoldFixture "test/fixtures/reservation-guard-tightened-twin.keiro" + let twinHoles = [moduleText m | m <- twinMods, kind m == HoleStub] + twinHoles `shouldSatisfy` any (T.isInfixOf "B.replayOnly") + let twinHarness = generatedTextEndingIn "Harness.hs" twinMods + T.count "forwardReplayRequestTransferReservation ::" twinHarness `shouldBe` 1 + plainMods <- scaffoldFixture "test/fixtures/reservation.keiro" + let plainHoles = [moduleText m | m <- plainMods, kind m == HoleStub] + plainHoles `shouldSatisfy` all (not . T.isInfixOf "B.replayOnly") + +comparisonProvenance :: CompareProvenance +comparisonProvenance = + CompareProvenance + { cpHistoricalCodecIdentity = "example.historical" + , cpHistoricalCodecVersion = "legacy-v1" + , cpCanonicalType = CanonicalTypeId "example.Artifact.v1" + , cpBindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding" + , cpBindingVersion = BindingVersion "1" + , cpWireFingerprint = "deadbeef" + } + +syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule +syntheticGenerated path contents = + ScaffoldModule{modulePath = path, moduleText = contents, kind = Generated, origin = "test"} + +generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text +generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of + contents : _ -> contents + [] -> "" + +onlyAggregate :: Spec -> Aggregate +onlyAggregate spec = case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> aggregate + aggregates -> error ("expected one aggregate, got " <> show (length aggregates)) + +loweringAggregateSpec :: T.Text +loweringAggregateSpec = + T.unlines + [ "context samples" + , "" + , "aggregate Counter" + , " regs" + , " note Text = \"hello world\"" + , " count Int = 0" + , " state CounterVertex = Pending" + , " states Pending Done!" + , " command Bump { count:Int }" + , " event CountBumped { count:Int }" + , " Pending -- Bump --> emit CountBumped ; goto Done" + ] + +exactStatusSpec :: T.Text +exactStatusSpec = + T.unlines + [ "context samples" + , "" + , "aggregate Reservation" + , " regs" + , " state ReservationVertex = Open" + , " states Open Closed!" + , " command Bump { count:Int }" + , " event ReservationHeld { count:Int }" + , " event ReservationUnHeld { count:Int }" + , " event CountBumped { count:Int }" + , " Open -- Bump --> emit CountBumped ; goto Closed" + , " projection reservation_status consistency=Eventual key=count" + , " status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }" + ] + +hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool +hasPathCollisionWithTwoOrigins = \case + Left refusals -> any hasTwo refusals + Right _ -> False + where + hasTwo (PathCollision _ origins) = length origins == 2 + hasTwo _ = False + +isMissingBannerRefusal :: Either [Refusal] a -> Bool +isMissingBannerRefusal = \case + Left [MissingGeneratedBanner paths] -> not (null paths) + _ -> False + +isSuccessfulScaffold :: Either [Refusal] a -> Bool +isSuccessfulScaffold = \case + Right _ -> True + Left _ -> False + +executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport +executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of + Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable" + Right modules -> do + result <- executeScaffold out False specPath ctx spec modules + case result of + Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable" + Right report -> pure report + +renameCounter :: Node -> Node +renameCounter (NAggregate aggregate) = + NAggregate + aggregate + { aggName = "Widget" + , aggRegs = [reg{regType = if regType reg == "CounterVertex" then "WidgetVertex" else regType reg} | reg <- aggRegs aggregate] + } +renameCounter node = node + +onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath +onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of + [path] -> path + paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths) + +withTempDirectory :: String -> (FilePath -> IO a) -> IO a +withTempDirectory template = bracket acquire removePathForcibly + where + acquire = do + base <- getTemporaryDirectory + (path, handle) <- openTempFile base template + hClose handle + removeFile path + createDirectory path + pure path + +{- | Parse a fixture and return the validator's diagnostic codes (failing the +test on a parse error). +-} +diagnosticCodesOf :: FilePath -> IO [DiagnosticCode] +diagnosticCodesOf path = do + map code <$> diagnosticsOf path + +-- | Parse a fixture and return all validator diagnostics. +diagnosticsOf :: FilePath -> IO [Diagnostic] +diagnosticsOf path = do + input <- readTestText path + case parseSpec path input of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right spec -> pure (validateSpec spec) + +{- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g. +the benign-inversion notices, are excluded). +-} +errorCodesOf :: FilePath -> IO [DiagnosticCode] +errorCodesOf path = do + diagnostics <- diagnosticsOf path + pure [code d | d <- diagnostics, severity d == Error] + +{- | Parse two fixtures and diff them (old, new). +| Plan 143: render an Expr in concrete guard syntax by printing a dummy +transition through the real pretty-printer and slicing its guard clause, +so the test exercises the exact printer the diff advisory uses. +-} +renderExprText :: Expr -> T.Text +renderExprText e = + case [T.strip l | l <- T.lines rendered, "guard " `T.isPrefixOf` T.strip l] of + [guardLine] -> T.strip (T.drop (T.length "guard ") guardLine) + _ -> error ("renderExprText: unexpected printer output: " <> T.unpack rendered) + where + rendered = + renderTransition + Transition + { tSource = "S" + , tCommand = "C" + , tGuard = Just e + , tWrites = [] + , tEmits = [] + , tGoto = "S" + , tMode = TmLive + , tLoc = noLoc + } + +{- | Plan 143: a minimal spec whose only transition is replay-only, with the +supplied clause lines spliced into its body. +-} +replayOnlySpecWith :: [T.Text] -> T.Text +replayOnlySpecWith clauseLines = + T.unlines $ + [ "context hospital-capacity" + , "" + , "id TransferReservationId prefix=rsv" + , "" + , "aggregate Reservation" + , " regs" + , " reservationId TransferReservationId = placeholder" + , " reservationState ReservationVertex = Unrequested" + , " states Unrequested Held" + , "" + , " command RequestTransferReservation { reservationId }" + , "" + , " event TransferReservationCreated = fields(RequestTransferReservation)" + , "" + , " replay-only Unrequested -- RequestTransferReservation -->" + ] + ++ clauseLines + +diffFixtures :: FilePath -> FilePath -> IO [Change] +diffFixtures oldP newP = do + old <- readTestText oldP + new <- readTestText newP + case (,) <$> parseSpec oldP old <*> parseSpec newP new of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right (o, n) -> pure (diffSpecs o n) + +kindOfChange :: Change -> ChangeKind +kindOfChange (Additive kind) = kind +kindOfChange (Advisory kind) = kind +kindOfChange (Breaking kind) = kind + +labelOfChange :: Change -> Label +labelOfChange Additive{} = LabelAdditive +labelOfChange Advisory{} = LabelAdvisory +labelOfChange Breaking{} = LabelBreaking + +genSurfaceSet :: Gen (Set.Set CompatibilitySurface) +genSurfaceSet = Set.fromList <$> listOf (elements [minBound .. maxBound]) + +genCompatibilityVector :: Gen CompatibilityVector +genCompatibilityVector = + CompatibilityVector + <$> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> (Set.fromList <$> listOf (elements rolloutConstraints)) + where + genVerdict = elements [VCompatible, VAdvisory, VBreaking, VNotApplicable] + rolloutConstraints = + [ RolloutStopTheWorld + , RolloutWorkersFirst + , RolloutDrainRequired + , RolloutProducerLast + ] + +replayImpactFixtures :: FilePath -> FilePath -> IO ReplayImpact +replayImpactFixtures oldPath newPath = do + old <- specOf oldPath + new <- specOf newPath + pure (ReplayImpact.replayImpact old new) + +modifyAggregate :: Name -> (Aggregate -> Aggregate) -> Spec -> Spec +modifyAggregate target update spec = + spec + { specNodes = + [ case node of + NAggregate aggregate | aggName aggregate == target -> NAggregate (update aggregate) + _ -> node + | node <- specNodes spec + ] + } + +modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec +modifyReadModel target update spec = + spec + { specNodes = + [ case node of + NReadModel readModel | rmName readModel == target -> NReadModel (update readModel) + _ -> node + | node <- specNodes spec + ] + } + +removeReadModel :: Name -> Spec -> Spec +removeReadModel target spec = + spec{specNodes = [node | node <- specNodes spec, not (isTarget node)]} + where + isTarget (NReadModel readModel) = rmName readModel == target + isTarget _ = False + +modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec +modifyRouter target update spec = + spec + { specNodes = + [ case node of + NRouter router | rtId router == target -> NRouter (update router) + _ -> node + | node <- specNodes spec + ] + } + +routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode] +routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update + +modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec +modifyProcess target update spec = + spec + { specNodes = + [ case node of + NProcess process | procId process == target -> NProcess (update process) + _ -> node + | node <- specNodes spec + ] + } + +processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode] +processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update + +errorCodes :: Spec -> [DiagnosticCode] +errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error] + +changeReadModelShape :: ReadModelNode -> ReadModelNode +changeReadModelShape readModel = + readModel + { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False] + , rmShape = "fnv1a:0000000000000000" + } + +{- | Assert a @new \@ skeleton parses and validates with zero +error-severity diagnostics. +-} +assertSkeletonValid :: T.Text -> IO () +assertSkeletonValid kind = case skeletonFor kind of + Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) + Right src -> case parseSpec ("new:" <> T.unpack kind) src of + Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr)) + Right spec -> + [code d | d <- validateSpec spec, severity d == Error] + `shouldBe` ([] :: [DiagnosticCode]) + +assertSkeletonScaffoldable :: T.Text -> IO () +assertSkeletonScaffoldable kind = case skeletonFor kind of + Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) + Right src -> case parseSpec ("new:" <> T.unpack kind) src of + Left perr -> expectationFailure (T.unpack perr) + Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold + +skeletonModuleRoots :: [(T.Text, T.Text)] +skeletonModuleRoots = + [ ("aggregate", "SkelAggregate") + , ("process", "SkelProcess") + , ("router", "SkelRouter") + , ("contract", "SkelContract") + , ("intake", "SkelIntake") + , ("emit", "SkelEmit") + , ("workqueue", "SkelQueue") + , ("workflow", "SkelWorkflow") + ] + +assertSkeletonMatchesCommitted :: T.Text -> T.Text -> IO () +assertSkeletonMatchesCommitted kind root = case skeletonFor kind of + Left err -> expectationFailure (T.unpack err) + Right source -> case parseSpec ("new:" <> T.unpack kind) source of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + let ctx = (defaultContext (specContext spec)){moduleRoot = root} + forM_ [m | m <- scaffoldModules ctx spec, kindOf m == Generated] $ \m -> do + committed <- readTestText ("test/conformance-skeletons/" <> modulePath m) + normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) + where + kindOf = Keiro.Dsl.Scaffold.kind + +bumpArtifactBindingVersion :: MappedDecl -> MappedDecl +bumpArtifactBindingVersion declaration@MappedStructural{msName = "ArtifactInfo"} = + declaration{msBindingVersion = Just "2"} +bumpArtifactBindingVersion declaration = declaration + +addArtifactSummaryField :: MappedDecl -> MappedDecl +addArtifactSummaryField declaration@MappedStructural{msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} = + declaration + { msShape = + ShapeRecord + constructor + unknownFields + ( fields + <> [ WireField + { wfHaskell = "summary" + , wfKey = "summary" + , wfType = TText + , wfPresence = PRequired + , wfOnMissing = Nothing + , wfLoc = Loc 0 + } + ] + ) + } +addArtifactSummaryField declaration = declaration + +expectGenericCompileFailure :: FilePath -> String -> Expectation +expectGenericCompileFailure fixture expectedDiagnostic = do + let fixtureDir = "../keiro-core/test/compile-fail" fixture + fixtureSource = fixtureDir "Fixture.hs" + (exitCode, standardOutput, standardError) <- + readProcessWithExitCode + "cabal" + [ "exec" + , "--" + , "ghc" + , "-XGHC2024" + , "-fno-code" + , "-fforce-recomp" + , "-i../keiro-core/src" + , "-i" <> fixtureDir + , fixtureSource + ] + "" + exitCode `shouldSatisfy` (/= ExitSuccess) + let compilerOutput = standardOutput <> standardError + compilerOutput `shouldContain` expectedDiagnostic + compilerOutput `shouldContain` "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." + compilerOutput `shouldContain` fixtureSource + +moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl +moveArtifactBindingIntoGenerated declaration@MappedStructural{msName = "ArtifactInfo"} = + declaration{msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"} +moveArtifactBindingIntoGenerated declaration = declaration + +removeMappedRegisterRequirements :: Spec -> Spec +removeMappedRegisterRequirements spec = + spec + { specMapped = map removeInitial (specMapped spec) + , specNodes = map removeRegisters (specNodes spec) + } + where + removeInitial declaration@MappedStructural{} = declaration{msInitial = Nothing} + removeInitial declaration@MappedOpaque{} = declaration{moInitial = Nothing} + removeRegisters (NAggregate aggregate) = + NAggregate + aggregate + { aggRegs = [] + , aggTransitions = [transition{tWrites = []} | transition <- aggTransitions aggregate] + } + removeRegisters node = node + +isImportCycle :: Refusal -> Bool +isImportCycle ImportCycle{} = True +isImportCycle _ = False + +isLoweringRefusal :: Either [Refusal] modules -> Bool +isLoweringRefusal (Left refusals) = any isLowering refusals + where + isLowering LoweringRefusal{} = True + isLowering _ = False +isLoweringRefusal (Right _) = False + +-- | Parse a fixture into a 'Spec', failing the test on a parse error. +specOf :: FilePath -> IO Spec +specOf path = do + input <- readTestText path + case parseSpec path input of + Left err -> expectationFailure (T.unpack err) >> error "unreachable" + Right spec -> pure spec + +-- | Parse a fixture and scaffold every aggregate in it. +scaffoldFixture :: FilePath -> IO [ScaffoldModule] +scaffoldFixture path = do + input <- readTestText path + case parseSpec path input of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right spec -> + pure $ + concat + [ scaffoldAggregate (ctx spec) spec agg <> harnessFor (ctx spec) spec agg + | NAggregate agg <- specNodes spec + ] + where + ctx spec = defaultContext (specContext spec) + +scaffoldProcessFixture :: FilePath -> IO [ScaffoldModule] +scaffoldProcessFixture path = do + input <- readTestText path + case parseSpec path input of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right spec -> + pure $ concat [scaffoldProcess (ctx spec) p | NProcess p <- specNodes spec] + where + ctx spec = defaultContext (specContext spec) + +{- | Assert a freshly-scaffolded Generated module matches its committed copy +under test/conformance/ (whitespace-normalized). The committed copies are the +ones the keiro-dsl-conformance suite compiles, so this pins the live scaffolder +to known-compiling output. +-} +assertMatchesCommitted :: ScaffoldModule -> IO () +assertMatchesCommitted m = do + let committedPath = "test/conformance/" <> modulePath m + committed <- readTestText committedPath + normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) + +normalizeGenerated :: T.Text -> (T.Text, [T.Text]) +normalizeGenerated text = + let (imports, body) = partition isImport (T.lines text) + in (normalizeBody body, sort (map normalizeImport imports)) + where + -- Compare the deterministic body exactly as before and imports as a sorted, + -- whitespace-normalized list. Sorting tolerates formatter reordering while + -- additions, removals, and renamed imports now fail the pin. + normalizeBody = + T.replace " , )" " )" + . T.unwords + . T.words + . T.replace "}" " } " + . T.replace "{" " { " + . T.replace "]" " ] " + . T.replace "[" " [ " + . T.replace "," " , " + . T.unlines + normalizeImport line = + let reordered = case T.words line of + "import" : "qualified" : moduleName : rest -> T.unwords ("import" : moduleName : "qualified" : rest) + wordsInImport -> T.unwords wordsInImport + (prefix, explicit) = T.breakOn " (" reordered + in if T.null explicit + then prefix + else + let members = + sort + . map (T.unwords . T.words) + . T.splitOn "," + . T.dropEnd 1 + $ T.drop 2 explicit + in prefix <> " (" <> T.intercalate "," members <> ")" + isImport line = case T.words line of + "import" : _ -> True + _ -> False + +{- | Locate and read a test fixture or committed conformance source regardless +of whether the suite was launched from the package directory or repo root. +-} +readTestText :: FilePath -> IO T.Text +readTestText path = resolveTestPath path >>= TIO.readFile + +-- | Locate a repo file regardless of the test process's current directory. +resolveTestPath :: FilePath -> IO FilePath +resolveTestPath rel = do + override <- lookupEnv "KEIRO_DSL_TEST_ROOT" + let candidates = [rel, "keiro-dsl" rel] <> maybe [] (\root -> [root rel]) override + existing <- filterM doesFileExist candidates + case existing of + path : _ -> pure path + [] -> + fail $ + "unable to locate keiro-dsl test file " + <> show rel + <> "; tried " + <> show candidates + +leftContains :: T.Text -> Either T.Text a -> Bool +leftContains needle = \case + Left err -> needle `T.isInfixOf` err + Right _ -> False + +parseInlineSpec :: FilePath -> T.Text -> IO Spec +parseInlineSpec sourceName src = case parseSpec sourceName src of + Left err -> expectationFailure (T.unpack err) >> error "unreachable" + Right spec -> pure spec + +shouldResolveTypeGraph :: Spec -> IO TypeGraph +shouldResolveTypeGraph spec = case resolveTypeGraph spec of + Left errors -> expectationFailure ("type graph failed: " <> show errors) >> error "unreachable" + Right graph -> pure graph + +shouldResolveCoverage :: FilePath -> Spec -> IO Coverage.CoverageReport +shouldResolveCoverage path spec = case Coverage.coverageReport path spec of + Left errors -> expectationFailure ("coverage graph failed: " <> show errors) >> error "unreachable" + Right report -> pure report + +withoutVendorGeometry :: Spec -> Spec +withoutVendorGeometry spec = + spec + { specMapped = filter (not . isVendorGeometry) (specMapped spec) + , specNodes = map stripNode (specNodes spec) + } + where + isVendorGeometry MappedOpaque{moName = "VendorGeometry"} = True + isVendorGeometry _ = False + stripNode (NAggregate aggregate) = + NAggregate + aggregate + { aggRegs = filter ((/= "VendorGeometry") . regType) (aggRegs aggregate) + , aggCommands = map stripCommand (aggCommands aggregate) + , aggEvents = map stripEvent (aggEvents aggregate) + } + stripNode node = node + stripCommand command = command{cmdFields = filter ((/= Just "VendorGeometry") . fieldType) (cmdFields command)} + stripEvent event = event{evBody = case evBody event of EventFields fields -> EventFields (filter ((/= Just "VendorGeometry") . fieldType) fields); body -> body} + +withMetadataJson :: Spec -> Spec +withMetadataJson spec = spec{specMapped = map updateDeclaration (specMapped spec)} + where + updateDeclaration declaration@MappedStructural{msName = "ArtifactMetadata", msShape = ShapeRecord constructor unknownFields fields} = + declaration + { msShape = + ShapeRecord + constructor + unknownFields + [if wfHaskell field == "note" then field{wfType = TJson} else field | field <- fields] + } + updateDeclaration declaration = declaration + +expressionTags :: TypeExprAlgebra [T.Text] +expressionTags = + TypeExprAlgebra + { onText = ["text"] + , onInt = ["int"] + , onBool = ["bool"] + , onNatural = ["natural"] + , onTime = ["time"] + , onJson = ["json"] + , onOptional = ("optional" :) + , onList = ("list" :) + , onMap = ("map" :) + , onRef = \key -> ["ref:" <> unMappedKey key] + } + +hasTypeGraphError :: (TypeGraphError -> Bool) -> Either (NonEmpty TypeGraphError) TypeGraph -> Bool +hasTypeGraphError predicate = \case + Left errors -> any predicate errors + Right _ -> False + +isRecursive :: TypeGraphError -> Bool +isRecursive TGRecursive{} = True +isRecursive _ = False + +isUnresolved :: TypeGraphError -> Bool +isUnresolved TGUnresolvedRef{} = True +isUnresolved _ = False + +mappedSpec :: [MappedDecl] -> Spec +mappedSpec declarations = Spec "mapped-test" Nothing Nothing [] [] [] declarations [] + +completeStructural :: Name -> MappedShape -> MappedDecl +completeStructural name shape = + MappedStructural + { msName = name + , msHaskell = Just (HaskellSource "mapped-test" "Example.Mapped" name) + , msBinding = Just ("Example.Mapped." <> T.toLower name <> "Binding") + , msBindingVersion = Just "1" + , msCanonical = Just ("example.mapped." <> name) + , msFixtures = Just ("Example.Mapped." <> T.toLower name <> "Cases") + , msInitial = Nothing + , msShape = shape + , msLoc = noLoc + } + +recordShape :: [TypeExpr] -> MappedShape +recordShape types = + ShapeRecord + "MappedRecord" + RejectUnknown + [ WireField + { wfHaskell = "field" <> T.pack (show index) + , wfKey = "field" <> T.pack (show index) + , wfType = fieldType + , wfPresence = PRequired + , wfOnMissing = Nothing + , wfLoc = noLoc + } + | (index, fieldType) <- zip [(1 :: Int) ..] types + ] + +mapArtifactField :: (WireField -> WireField) -> Spec -> Spec +mapArtifactField = mapArtifactNamedField "key" + +mapArtifactNamedField :: Name -> (WireField -> WireField) -> Spec -> Spec +mapArtifactNamedField target transform spec = spec{specMapped = map updateDeclaration (specMapped spec)} + where + updateDeclaration declaration@MappedStructural{msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} = + declaration + { msShape = + ShapeRecord + constructor + unknownFields + [if wfHaskell field == target then transform field else field | field <- fields] + } + updateDeclaration declaration = declaration + +mapMappedStructural :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec +mapMappedStructural target transform spec = + spec + { specMapped = + [ case declaration of + MappedStructural{msName = name} + | name == target -> transform declaration + _ -> declaration + | declaration <- specMapped spec + ] + } + +renameRecordConstructor :: MappedShape -> MappedShape +renameRecordConstructor (ShapeRecord _ unknownFields fields) = ShapeRecord "ArtifactInfoV2" unknownFields fields +renameRecordConstructor shape = shape + +renameMappedRecordConstructor :: MappedDecl -> MappedDecl +renameMappedRecordConstructor declaration@MappedStructural{msShape = shape} = + declaration{msShape = renameRecordConstructor shape} +renameMappedRecordConstructor declaration = declaration + +changeMappedCanonical :: MappedDecl -> MappedDecl +changeMappedCanonical declaration@MappedStructural{} = + declaration{msCanonical = Just "example.artifact.ArtifactInfo.v2"} +changeMappedCanonical declaration = declaration + +data MappedMutation = MappedMutation + { mmCandidate :: !Spec + , mmCode :: !DiagnosticCode + , mmExpectedSubjects :: !(Set.Set T.Text) + } + deriving stock (Show) + +mappedWireMutations :: Spec -> [MappedMutation] +mappedWireMutations spec = case resolveTypeGraph spec of + Left _ -> [] + Right graph -> concatMap (uncurry (declarationMutations graph)) (zip [0 :: Int ..] (specMapped spec)) + where + declarationMutations graph declarationIndex declaration = case declaration of + MappedStructural{msName = declarationName, msShape = shape} -> case shape of + ShapeRecord _ _ fields -> + concat + [ [ mutation + graph + declarationName + MappedWireKeyChanged + (fieldSubject field{wfKey = wfKey field <> "__mutated"}) + (mutateRecordField declarationIndex fieldIndex (\value -> value{wfKey = wfKey value <> "__mutated"}) spec) + , mutation + graph + declarationName + MappedPresenceChanged + (fieldSubject field) + (mutateRecordField declarationIndex fieldIndex (\value -> value{wfPresence = flipPresence (wfPresence value)}) spec) + ] + <> [ mutation + graph + declarationName + defaultCode + (fieldSubject field) + (mutateRecordField declarationIndex fieldIndex (\value -> value{wfOnMissing = changedDefault}) spec) + | oldDefault <- maybeToListTest (wfOnMissing field) + , let (changedDefault, defaultCode) = mutateDefault oldDefault + ] + | (fieldIndex, field) <- zip [0 :: Int ..] fields + ] + ShapeEnum entries -> + [ mutation + graph + declarationName + MappedEnumSpellingChanged + (enumSubject entry{weTag = weTag entry <> "__mutated"}) + (mutateEnumEntry declarationIndex entryIndex (\value -> value{weTag = weTag value <> "__mutated"}) spec) + | (entryIndex, entry) <- zip [0 :: Int ..] entries + ] + ShapeUnion _ arms -> + [ mutation + graph + declarationName + MappedArmTagChanged + (armSubject arm{waTag = waTag arm <> "__mutated"}) + (mutateUnionArm declarationIndex armIndex (\value -> value{waTag = waTag value <> "__mutated"}) spec) + | (armIndex, arm) <- zip [0 :: Int ..] arms + ] + MappedOpaque{moName = declarationName, moCodecVersion = version} -> + [ mutation + graph + declarationName + MappedOpaqueCodecChanged + "codec" + ( updateMappedAt + declarationIndex + ( \case + value@MappedOpaque{} -> value{moCodecVersion = fmap (<> "__mutated") version} + value -> value + ) + spec + ) + ] + + mutation graph declarationName diagnosticCode leaf candidate = + MappedMutation + { mmCandidate = candidate + , mmCode = diagnosticCode + , mmExpectedSubjects = + Set.fromList + [ renderUsePath path <> " " <> leaf + | path <- usePaths graph declarationName + ] + } + +fieldSubject :: WireField -> T.Text +fieldSubject field = ".field " <> wfHaskell field <> "[\"" <> wfKey field <> "\"]" + +enumSubject :: WireEnum -> T.Text +enumSubject entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]" + +armSubject :: WireArm -> T.Text +armSubject arm = ".arm " <> waCtor arm <> "[\"" <> waTag arm <> "\"]" + +flipPresence :: Presence -> Presence +flipPresence PRequired = POptional +flipPresence POptional = PRequired + +mutateDefault :: OnMissing -> (Maybe OnMissing, DiagnosticCode) +mutateDefault = \case + OmNull -> (Nothing, MappedDefaultRemoved) + OmText value -> (Just (OmText (value <> "__mutated")), MappedDefaultChanged) + OmInt value -> (Just (OmInt (value + 1)), MappedDefaultChanged) + OmBool value -> (Just (OmBool (not value)), MappedDefaultChanged) + OmEmptyList -> (Nothing, MappedDefaultRemoved) + OmEmptyMap -> (Nothing, MappedDefaultRemoved) + OmCtor constructor -> (Just (OmCtor (constructor <> "Mutated")), MappedDefaultChanged) + +mutateRecordField :: Int -> Int -> (WireField -> WireField) -> Spec -> Spec +mutateRecordField declarationIndex fieldIndex transform = + updateMappedAt declarationIndex $ \case + declaration@MappedStructural{msShape = ShapeRecord constructor unknownFields fields} -> + declaration{msShape = ShapeRecord constructor unknownFields (updateAt fieldIndex transform fields)} + declaration -> declaration + +mutateEnumEntry :: Int -> Int -> (WireEnum -> WireEnum) -> Spec -> Spec +mutateEnumEntry declarationIndex entryIndex transform = + updateMappedAt declarationIndex $ \case + declaration@MappedStructural{msShape = ShapeEnum entries} -> + declaration{msShape = ShapeEnum (updateAt entryIndex transform entries)} + declaration -> declaration + +mutateUnionArm :: Int -> Int -> (WireArm -> WireArm) -> Spec -> Spec +mutateUnionArm declarationIndex armIndex transform = + updateMappedAt declarationIndex $ \case + declaration@MappedStructural{msShape = ShapeUnion encoding arms} -> + declaration{msShape = ShapeUnion encoding (updateAt armIndex transform arms)} + declaration -> declaration + +updateMappedAt :: Int -> (MappedDecl -> MappedDecl) -> Spec -> Spec +updateMappedAt declarationIndex transform spec = + spec{specMapped = updateAt declarationIndex transform (specMapped spec)} + +updateAt :: Int -> (a -> a) -> [a] -> [a] +updateAt target transform values = + [if index == target then transform value else value | (index, value) <- zip [0 :: Int ..] values] + +maybeToListTest :: Maybe a -> [a] +maybeToListTest = maybe [] pure + +isAdditiveChange :: Change -> Bool +isAdditiveChange Additive{} = True +isAdditiveChange Advisory{} = False +isAdditiveChange Breaking{} = False + +mappedIngredientMutations :: Spec -> [(Spec, DiagnosticCode)] +mappedIngredientMutations spec = + [ (mapMappedStructural "ArtifactInfo" clearStructuralHaskell spec, MappedMissingIngredient) + , (mapMappedStructural "ArtifactInfo" clearStructuralBinding spec, MappedMissingIngredient) + , (mapMappedStructural "ArtifactInfo" clearStructuralBindingVersion spec, MappedMissingIngredient) + , (mapMappedStructural "ArtifactInfo" clearStructuralCanonical spec, MappedMissingIngredient) + , (mapMappedStructural "ArtifactInfo" clearStructuralFixtures spec, MappedMissingIngredient) + , (mapMappedStructural "ArtifactInfo" clearStructuralInitial spec, MappedMissingInitialValue) + , (mapMappedDeclaration "VendorGeometry" clearOpaqueHaskell spec, MappedMissingIngredient) + , (mapMappedDeclaration "VendorGeometry" clearOpaqueCodec spec, MappedMissingIngredient) + , (mapMappedDeclaration "VendorGeometry" clearOpaqueCodecVersion spec, MappedMissingIngredient) + , (mapMappedDeclaration "VendorGeometry" clearOpaqueFixtures spec, MappedMissingIngredient) + ] + where + clearStructuralHaskell declaration@MappedStructural{} = declaration{msHaskell = Nothing} + clearStructuralHaskell declaration = declaration + clearStructuralBinding declaration@MappedStructural{} = declaration{msBinding = Nothing} + clearStructuralBinding declaration = declaration + clearStructuralBindingVersion declaration@MappedStructural{} = declaration{msBindingVersion = Nothing} + clearStructuralBindingVersion declaration = declaration + clearStructuralCanonical declaration@MappedStructural{} = declaration{msCanonical = Nothing} + clearStructuralCanonical declaration = declaration + clearStructuralFixtures declaration@MappedStructural{} = declaration{msFixtures = Nothing} + clearStructuralFixtures declaration = declaration + clearStructuralInitial declaration@MappedStructural{} = declaration{msInitial = Nothing} + clearStructuralInitial declaration = declaration + clearOpaqueHaskell declaration@MappedOpaque{} = declaration{moHaskell = Nothing} + clearOpaqueHaskell declaration = declaration + clearOpaqueCodec declaration@MappedOpaque{} = declaration{moCodecId = Nothing} + clearOpaqueCodec declaration = declaration + clearOpaqueCodecVersion declaration@MappedOpaque{} = declaration{moCodecVersion = Nothing} + clearOpaqueCodecVersion declaration = declaration + clearOpaqueFixtures declaration@MappedOpaque{} = declaration{moFixtures = Nothing} + clearOpaqueFixtures declaration = declaration + +mapMappedDeclaration :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec +mapMappedDeclaration target transform spec = + spec + { specMapped = + [ if mappedDeclarationName declaration == target then transform declaration else declaration + | declaration <- specMapped spec + ] + } + +mappedDeclarationName :: MappedDecl -> Name +mappedDeclarationName MappedStructural{msName = name} = name +mappedDeclarationName MappedOpaque{moName = name} = name + +statusMapSpec :: T.Text -> T.Text +statusMapSpec marker = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " event Created { }" + , " event Changed { }" + , "" + , " projection things consistency=Eventual key=thingId" + , " status-map" <> marker <> " { Created=>held }" + ] + +parseErrorOf :: FilePath -> T.Text -> IO T.Text +parseErrorOf sourceName src = case parseSpec sourceName src of + Left err -> pure err + Right _ -> expectationFailure ("expected parse failure for " <> sourceName) >> error "unreachable" + +duplicateGotoSpec :: T.Text +duplicateGotoSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states A B C" + , "" + , " command Go { }" + , " A -- Go -->" + , " goto B" + , " goto C" + ] + +missingGotoSpec :: T.Text +missingGotoSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states A B" + , "" + , " command Go { }" + , " A -- Go -->" + , " emit Changed" + ] + +duplicateWireSpec :: T.Text +duplicateWireSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " wire kind=ctorName fields=camelCase schemaVersion=1" + , " wire kind=typeName fields=snakeCase schemaVersion=2" + ] + +duplicateProjectionSpec :: T.Text +duplicateProjectionSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " projection first consistency=Strong key=thingId" + , " status-map partial { }" + , " projection second consistency=Eventual key=thingId" + ] + +projectionWithoutConsistencySpec :: T.Text +projectionWithoutConsistencySpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " projection things key=thingId" + ] + +malformedRegisterSpec :: T.Text +malformedRegisterSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " status Status" + , " states Open" + ] + +misplacedDispatchIdSpec :: T.Text +misplacedDispatchIdSpec = + T.replace + " schedule timer\n\n dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n" + " dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n schedule timer\n" + (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [NProcess (processWithLiteral "literal")])) + +lineNumberContaining :: T.Text -> T.Text -> Int +lineNumberContaining needle = go 1 . T.lines + where + go current = \case + [] -> current + lineText : rest + | needle `T.isInfixOf` lineText -> current + | otherwise -> go (current + 1) rest + +decimalOverflow :: T.Text +decimalOverflow = "18446744073709551617" + +decimalOverflowSpecs :: [(String, T.Text)] +decimalOverflowSpecs = + [ ("event-version", eventVersionDecimalSpec decimalOverflow) + , ("wire-schema", wireDecimalSpec decimalOverflow) + , ("contract-schema", contractDecimalSpec decimalOverflow) + , ("decode-schema", decodeDecimalSpec decimalOverflow) + , ("publisher-attempts", publisherDecimalSpec decimalOverflow) + , ("workqueue-retries", workqueueDecimalSpec decimalOverflow) + , ("timer-attempts", timerDecimalSpec decimalOverflow) + ] + +eventVersionDecimalSpec :: T.Text -> T.Text +eventVersionDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " event Changed v" <> value <> " { }" + ] + +wireDecimalSpec :: T.Text -> T.Text +wireDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "aggregate Thing" + , " regs" + , " states Open" + , "" + , " wire kind=ctorName fields=camelCase schemaVersion=" <> value + ] + +contractDecimalSpec :: T.Text -> T.Text +contractDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "contract Contract {" + , " schemaVersion " <> value + , " discriminator kind" + , "}" + ] + +decodeDecimalSpec :: T.Text -> T.Text +decodeDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "intake Inbox {" + , " contract Contract" + , " topic events" + , " accept Event" + , " dedupe key messageId policy PreferIntegrationMessageId" + , " decode { envelope strict-required lenient-optional body strict schemaVersion == " <> value <> " }" + , " disposition { }" + , "}" + ] + +publisherDecimalSpec :: T.Text -> T.Text +publisherDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "publisher Publisher {" + , " emit Emit" + , " ordering PerKeyHeadOfLine" + , " maxAttempts " <> value + , " backoff constant 2s" + , " outboxId stable from messageId" + , "}" + ] + +workqueueDecimalSpec :: T.Text -> T.Text +workqueueDecimalSpec value = + T.unlines + [ "context svc" + , "" + , "workqueue Queue {" + , " queue logical = \"queue\"" + , " derive physical = \"queue\"" + , " dlq = \"queue_dlq\"" + , " table = \"pgmq.q_queue\"" + , " payload Job { }" + , " retry maxRetries = " <> value <> " delay = 5s dlq = on" + , " disposition { }" + , "}" + ] + +timerDecimalSpec :: T.Text -> T.Text +timerDecimalSpec value = + T.replace + "max-attempts 5" + ("max-attempts " <> value) + (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [NProcess (processWithLiteral "literal")])) + +identifierHygieneSpec :: T.Text +identifierHygieneSpec = + T.unlines + [ "context svc" + , "" + , "aggregate thing" + , " regs" + , " states Open" + , "" + , " command DoIt { data }" + ] + +vertexCollisionSpec :: T.Text +vertexCollisionSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Reservation" + , " regs" + , " states Created" + , "" + , " event ReservationCreated { }" + ] + +underscoreNodeSpec :: T.Text +underscoreNodeSpec = + T.unlines + [ "context svc" + , "" + , "contract _contract {" + , " schemaVersion 1" + , " discriminator kind" + , "}" + ] + +unicodeIdentifierSpec :: T.Text +unicodeIdentifierSpec = + T.unlines + [ "context svc" + , "" + , "aggregate Résumé" + , " regs" + , " states Open" + ] + +emptyStatesSpec :: Spec +emptyStatesSpec = + Spec + "svc" + Nothing + Nothing + [] + [] + [] + [] + [NAggregate (Aggregate "Thing" [] [] [] [] [] Nothing Nothing Nothing noLoc)] + +crossFamilyBoundarySpec :: T.Text +crossFamilyBoundarySpec = + T.unlines + [ "context svc" + , "" + , "aggregate First" + , " regs" + , " states A B" + , " command Go { }" + , " A -- Go -->" + , " emit Changed" + , " goto B" + , "" + , "emit Output {" + , " contract Contract" + , " topic events" + , " source \"source\"" + , " key thingId" + , " map status { _ => skip }" + , " messageId derive hole" + , " idempotencyKey derive hole" + , "}" + , "" + , "aggregate Second" + , " regs" + , " states" + , "" + , "dispatch QueueDispatch {" + , " source readModel = source key = thingId" + , " fanout body = resolveFanout" + , " dedup key = thingId" + , " seenIn readModel = seen field = thingId" + , " seenIn queue = workQueue field = thingId" + , " enqueue to = workQueue" + , "}" + ] + +-------------------------------------------------------------------------------- +-- Generators (bounded; restricted to valid, non-reserved identifiers) +-------------------------------------------------------------------------------- + +{- | Text that exercises every supported escape plus notation punctuation that +used to be able to split one emit-map row into several rows. +-} +genAdversarialText :: Gen T.Text +genAdversarialText = + T.concat + <$> resize + 20 + (listOf (elements ["a", "Z", "\"", "\\", "\n", "\t", "\r", "=>", "#", "{", "}", " "])) + +{- | One spec carrying the same adversarial value through three distinct +printer paths: a contract topic, an emit-map value, and a quote-wrapped +field-binding literal. +-} +escapedSpec :: T.Text -> Spec +escapedSpec value = + Spec + "escape" + Nothing + Nothing + [] + [] + [] + [] + [ NContract + ContractNode + { ctrName = "Contract" + , ctrSchemaVersion = 1 + , ctrDiscriminator = "kind" + , ctrTopics = [("events", value)] + , ctrEvents = [] + , ctrLoc = noLoc + } + , NEmit + EmitNode + { emName = "Emit" + , emContract = "Contract" + , emTopic = "events" + , emSource = "source" + , emKey = "key" + , emDiscriminant = "status" + , emMap = [EmitMapRow value "Event" noLoc] + , emSkip = True + , emMessageId = DeriveSpec Nothing + , emIdempotencyKey = DeriveSpec Nothing + , emLoc = noLoc + } + , NProcess (processWithLiteral value) + ] + +processWithLiteral :: T.Text -> ProcessNode +processWithLiteral value = + ProcessNode + { procId = "Process" + , procName = "process" + , procInput = InputDecl "Input" [] + , procCorrelate = CorrelateDecl "key" "idText" + , procSaga = SagaRef "Saga" "saga" + , procTarget = "Target" + , procProjections = [] + , procHandle = + HandleNode + { hOn = "Input" + , hAdvance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))] + , hDispatch = [] + , hSchedule = "timer" + } + , procRejected = PolHalt + , procPoison = PolHalt + , procTimer = + TimerNode + { tmName = "timer" + , tmId = IdExpr UuidV5Id "timer:" + , tmFireAt = FireAtExpr "observedAt" "5m" + , tmPayload = [] + , tmFire = + FireNode + { fireTarget = "Target" + , fireKey = "correlationId" + , fireCommand = "Fire" + , fireFields = [] + , fireFiredEventId = IdExpr UuidV5Id "fired:" + , fireDisposition = FireDisposition OFired OFired ORetry ORetry ORetry + } + , tmDecodeUnknown = "Cancelled" + , tmMaxAttempts = 5 + , tmDeadLetter = "exhausted" + , tmLoc = noLoc + } + , procLoc = noLoc + } + +genName :: Gen Name +genName = + frequency + [ + ( 3 + , do + base <- elements ["Aa", "Bb", "Cc", "Dd", "St", "Cmd", "Ev", "Reg", "Fld", "Foo", "Bar", "Qux"] + n <- choose (0, 9 :: Int) + pure (T.pack (base <> show n)) + ) + , (1, elements ["data1", "typeA", "whereX", "gotoX", "guardY", "emitZ", "_lead"]) + ] + +genWire :: Gen T.Text +genWire = do + base <- elements ["red", "blue", "green", "ctorName", "camelCase", "rsv", "hosp", "held", "partial-divert", "1st"] + n <- choose (0, 9 :: Int) + pure (T.pack (base <> show n)) + +genWireWord :: Gen T.Text +genWireWord = genWire + +smallList :: Gen a -> Gen [a] +smallList g = choose (0, 3 :: Int) >>= \n -> vectorOf n g + +nonEmptyList :: Gen a -> Gen [a] +nonEmptyList g = choose (1, 3 :: Int) >>= \n -> vectorOf n g + +genMaybe :: Gen a -> Gen (Maybe a) +genMaybe g = oneof [pure Nothing, Just <$> g] + +genCmp :: Gen CmpOp +genCmp = elements [OpEq, OpNeq, OpLt, OpLe, OpGt, OpGe] + +genAtom :: Gen Expr +genAtom = EAtom <$> oneof [AName <$> genName, ABool <$> arbitrary] + +genExpr :: Gen Expr +genExpr = go (3 :: Int) + where + go 0 = genAtom + go d = + oneof + [ genAtom + , EOr <$> go (d - 1) <*> go (d - 1) + , EAnd <$> go (d - 1) <*> go (d - 1) + , ECmp <$> genCmp <*> go (d - 1) <*> go (d - 1) + ] + +genField :: Gen Field +genField = Field <$> genName <*> oneof [pure Nothing, Just <$> genName] + +genReg :: Gen RegDecl +genReg = RegDecl <$> genName <*> genName <*> genRegInitial <*> pure noLoc + +genRegInitial :: Gen RegInitial +genRegInitial = oneof [RegInitBare <$> genName, RegInitText <$> genAdversarialText] + +genState :: Gen StateDecl +genState = StateDecl <$> genName <*> arbitrary <*> pure noLoc + +genCommand :: Gen Command +genCommand = Command <$> genName <*> smallList genField <*> pure noLoc + +genEvent :: Gen Event +genEvent = do + name <- genName + eventBody <- body + version <- choose (1, 3) + upcast <- genMaybe ((,) <$> choose (0, 3) <*> pure Hole) + (retiring, deprecated) <- elements [(False, False), (True, False), (False, True)] + pure + Event + { evName = name + , evBody = eventBody + , evVersion = version + , evUpcastFrom = upcast + , evRetiring = retiring + , evDeprecated = deprecated + , evLoc = noLoc + } + where + body = oneof [EventFromCommand <$> genName, EventFields <$> smallList genField] + +genTransition :: Gen Transition +genTransition = + Transition + <$> genName + <*> genName + <*> genMaybe genExpr + <*> smallList ((,) <$> genName <*> genExpr) + <*> smallList genName + <*> genName + <*> elements [TmLive, TmReplayOnly] + <*> pure noLoc + +genWireSpec :: Gen WireSpec +genWireSpec = WireSpec <$> genWire <*> genWire <*> (getNonNegative <$> arbitrary) + +genProjection :: Gen ProjectionSpec +genProjection = + ProjectionSpec + <$> genName + <*> genMaybe (elements [Strong, Eventual]) + <*> genName + <*> genMaybe (Mapping <$> smallList ((,) <$> genName <*> genWire) <*> arbitrary) + <*> pure noLoc + +genAggregate :: Gen Aggregate +genAggregate = + Aggregate + <$> genName + <*> smallList genReg + <*> smallList genState + <*> smallList genCommand + <*> smallList genEvent + <*> smallList genTransition + <*> genMaybe genWireSpec + <*> genMaybe genProjection + <*> genMaybe (SnapshotSpec <$> oneof [SnapEvery <$> choose (0, 5), pure SnapOnTerminal] <*> choose (0, 5) <*> genAdversarialText <*> pure noLoc) + <*> pure noLoc + +genDottedRef :: Gen T.Text +genDottedRef = elements ["input.id", "input.hospitalId", "timer.id", "correlationId", "payload.messageId"] + +genWindow :: Gen T.Text +genWindow = elements ["0s", "5s", "2m", "1h"] + +genFieldBinding :: Gen FieldBinding +genFieldBinding = + FieldBinding + <$> genName + <*> oneof + [ pure Nothing + , Just <$> genDottedRef + , Just . (\raw -> "\"" <> raw <> "\"") <$> genAdversarialText + ] + +genDispatchDisposition :: Gen DispatchDisposition +genDispatchDisposition = DispatchDisposition <$> genDisp <*> genDisp <*> genDisp + where + genDisp = oneof [pure DAckOk, pure DRetry, DDeadLetter <$> genAdversarialText] + +genDispatchNode :: Gen DispatchNode +genDispatchNode = + DispatchNode + <$> genName + <*> genDottedRef + <*> genName + <*> smallList genFieldBinding + <*> genDispatchDisposition + <*> pure noLoc + +genFireDisposition :: Gen FireDisposition +genFireDisposition = + FireDisposition + <$> elements [OFired, ORetry] + <*> elements [OFired, ORetry] + <*> elements [OFired, ORetry] + <*> elements [OFired, ORetry] + <*> elements [OFired, ORetry] + +genIdExpr :: Gen IdExpr +genIdExpr = IdExpr UuidV5Id <$> genAdversarialText + +genFireNode :: Gen FireNode +genFireNode = + FireNode + <$> genName + <*> genDottedRef + <*> genName + <*> smallList genFieldBinding + <*> genIdExpr + <*> genFireDisposition + +genTimerNode :: Gen TimerNode +genTimerNode = + TimerNode + <$> genName + <*> genIdExpr + <*> (FireAtExpr <$> genName <*> genWindow) + <*> smallList genFieldBinding + <*> genFireNode + <*> genName + <*> choose (0, 5) + <*> genAdversarialText + <*> pure noLoc + +genProcess :: Gen ProcessNode +genProcess = + ProcessNode + <$> genName + <*> genAdversarialText + <*> (InputDecl <$> genName <*> smallList genField) + <*> (CorrelateDecl <$> genName <*> genName) + <*> (SagaRef <$> genName <*> genAdversarialText) + <*> genName + <*> smallList genName + <*> (HandleNode <$> genName <*> (AdvanceNode <$> genName <*> smallList genFieldBinding) <*> smallList genDispatchNode <*> genName) + <*> elements [PolHalt, PolDeadLetter, PolSkip] + <*> elements [PolHalt, PolDeadLetter, PolSkip] + <*> genTimerNode + <*> pure noLoc + +genResolveSource :: Gen ResolveSource +genResolveSource = oneof [ResolveReadModel <$> genName, pure ResolveHole] + +genRouter :: Gen RouterNode +genRouter = + RouterNode + <$> genName + <*> genAdversarialText + <*> (InputDecl <$> genName <*> smallList genField) + <*> (CorrelateDecl <$> genName <*> genName) + <*> (ResolveDecl <$> genResolveSource <*> smallList genName <*> pure noLoc) + <*> genName + <*> smallList genName + <*> (RouterDispatchNode <$> genName <*> smallList genFieldBinding <*> genDispatchDisposition <*> pure noLoc) + <*> elements [PolHalt, PolDeadLetter, PolSkip] + <*> elements [PolHalt, PolDeadLetter, PolSkip] + <*> pure noLoc + +genContractField :: Gen ContractField +genContractField = ContractField <$> genName <*> oneof [CTypeId <$> genAdversarialText, pure CText, pure CInt] + +genContractEvent :: Gen ContractEvent +genContractEvent = ContractEvent <$> genName <*> genName <*> smallList genContractField + +genContract :: Gen ContractNode +genContract = + ContractNode + <$> genName + <*> choose (0, 5) + <*> genName + <*> smallList ((,) <$> genName <*> genAdversarialText) + <*> smallList genContractEvent + <*> pure noLoc + +genWireSource :: Gen WireSource +genWireSource = oneof [SrcHeader <$> genAdversarialText, pure SrcBody, pure SrcKafkaKey, pure SrcKafkaCursor] + +genInboxAction :: Gen InboxAction +genInboxAction = oneof [pure IAckOk, IRetry <$> genWindow, IDeadLetter <$> genMaybe genAdversarialText] + +genDispositionRow :: Gen DispositionRow +genDispositionRow = DispositionRow <$> genName <*> genInboxAction <*> pure noLoc + +genDecodeSpec :: Gen DecodeSpec +genDecodeSpec = + DecodeSpec + <$> ((\first second -> first <> " " <> second) <$> genWireWord <*> genWireWord) + <*> arbitrary + <*> choose (0, 5) + +genIntake :: Gen IntakeNode +genIntake = + IntakeNode + <$> genName + <*> genName + <*> genName + <*> nonEmptyList genName + <*> smallList (BindRow <$> genName <*> genWireSource <*> arbitrary <*> arbitrary) + <*> genName + <*> genName + <*> elements [InkPersistFull, InkPersistDedupeOnly] + <*> genDecodeSpec + <*> smallList genDispositionRow + <*> pure noLoc + +genDeriveSpec :: Gen DeriveSpec +genDeriveSpec = DeriveSpec <$> genMaybe genAdversarialText + +genEmit :: Gen EmitNode +genEmit = + EmitNode + <$> genName + <*> genName + <*> genName + <*> genAdversarialText + <*> genName + <*> genName + <*> smallList (EmitMapRow <$> genAdversarialText <*> genName <*> pure noLoc) + <*> arbitrary + <*> genDeriveSpec + <*> genDeriveSpec + <*> pure noLoc + +genPublisher :: Gen PublisherNode +genPublisher = + PublisherNode + <$> genName + <*> genName + <*> genName + <*> choose (0, 5) + <*> (BackoffSpec <$> genName <*> genWindow <*> genMaybe genWindow <*> genMaybe (elements ["1.0", "2.0", "3"])) + <*> genName + <*> pure noLoc + +genWqField :: Gen WqField +genWqField = WqField <$> genName <*> genAdversarialText <*> genName <*> arbitrary + +genWqDispRow :: Gen WqDispRow +genWqDispRow = WqDispRow <$> genName <*> genInboxAction <*> pure noLoc + +genWorkqueue :: Gen WorkqueueNode +genWorkqueue = + WorkqueueNode + <$> genName + <*> genAdversarialText + <*> genAdversarialText + <*> genAdversarialText + <*> genAdversarialText + <*> elements [WqUnordered, WqFifoThroughput, WqFifoRoundRobin] + <*> genMaybe (WqGroupKey <$> genName <*> genName <*> genMaybe genAdversarialText) + <*> oneof [pure WqStandard, pure WqUnlogged, WqPartitioned <$> genAdversarialText <*> genAdversarialText] + <*> genName + <*> smallList genWqField + <*> choose (0, 5) + <*> genWindow + <*> arbitrary + <*> smallList genWqDispRow + <*> pure noLoc + +genReadModel :: Gen ReadModelNode +genReadModel = + ReadModelNode + <$> genName + <*> genAdversarialText + <*> genAdversarialText + <*> smallList (RmColumn <$> genWireWord <*> genName <*> arbitrary) + <*> choose (0, 5) + <*> genAdversarialText + <*> elements [Strong, Eventual] + <*> genMaybe (oneof [pure RmEntireLog, RmCategory <$> genAdversarialText]) + <*> elements [RmInline, RmSubscription] + <*> genMaybe genAdversarialText + <*> pure noLoc + +genPgmqDispatch :: Gen PgmqDispatchNode +genPgmqDispatch = + PgmqDispatchNode + <$> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> genName + <*> pure noLoc + +genWfBodyItem :: Gen WfBodyItem +genWfBodyItem = sized go + where + go size = + oneof $ + [ WfStep <$> genWireWord <*> genName <*> pure noLoc + , WfAwait <$> genWireWord <*> genName <*> pure noLoc + , WfSleep <$> genWireWord <*> genName <*> pure noLoc + , WfChild <$> genWireWord <*> genName <*> genName <*> pure noLoc + , WfContinueAsNew <$> genName <*> pure noLoc + ] + ++ [ WfPatch <$> genWireWord <*> resize (size `div` 2) (smallList genWfBodyItem) <*> pure noLoc + | size > 0 + ] + +genWorkflow :: Gen WorkflowNode +genWorkflow = + WorkflowNode + <$> genName + <*> genAdversarialText + <*> genName + <*> smallList genField + <*> genName + <*> genMaybe genName + <*> genName + <*> smallList genWfBodyItem + <*> pure noLoc + +genOperationShape :: Gen OperationShape +genOperationShape = + oneof + [ CommandOp <$> genName <*> genName <*> genName <*> smallList genName + , QueryOp <$> genName <*> genName <*> ((\parts -> T.unwords parts) <$> nonEmptyList genName) <*> genName + , SignalOp <$> genWireWord <*> genName <*> genName <*> genName <*> genName + , RunOp <$> genName <*> genName <*> genName + ] + +genOperation :: Gen OperationNode +genOperation = OperationNode <$> genName <*> genOperationShape <*> pure noLoc + +allNodeTags :: [String] +allNodeTags = ["aggregate", "process", "router", "contract", "intake", "emit", "publisher", "workqueue", "pgmq-dispatch", "readmodel", "workflow", "operation"] + +nodeTag :: Node -> String +nodeTag = \case + NAggregate _ -> "aggregate" + NProcess _ -> "process" + NRouter _ -> "router" + NContract _ -> "contract" + NIntake _ -> "intake" + NEmit _ -> "emit" + NPublisher _ -> "publisher" + NWorkqueue _ -> "workqueue" + NPgmqDispatch _ -> "pgmq-dispatch" + NReadModel _ -> "readmodel" + NWorkflow _ -> "workflow" + NOperation _ -> "operation" + +genId :: Gen IdDecl +genId = IdDecl <$> genName <*> genWire <*> pure noLoc + +genEnum :: Gen EnumDecl +genEnum = EnumDecl <$> genName <*> smallList ((,) <$> genName <*> genWire) <*> pure noLoc + +genRule :: Gen RuleDecl +genRule = + RuleDecl + <$> genName + <*> genName + <*> genName + <*> nonEmptyList ((,) <$> genName <*> genExpr) + <*> pure noLoc + +genMappedDecls :: Gen [MappedDecl] +genMappedDecls = do + count <- choose (0, 4 :: Int) + let names = take count ["MappedA", "MappedB", "MappedC", "MappedD"] + traverse (genMappedDecl names) names + +genMappedDecl :: [Name] -> Name -> Gen MappedDecl +genMappedDecl names name = + oneof + [ MappedStructural name + <$> genMaybe genHaskellSource + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMappedShape names + <*> pure noLoc + , MappedOpaque name + <$> genMaybe genHaskellSource + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> genMaybe genAdversarialText + <*> pure noLoc + ] + +genHaskellSource :: Gen HaskellSource +genHaskellSource = + HaskellSource + <$> genWire + <*> genModuleRoot + <*> genName + +genMappedShape :: [Name] -> Gen MappedShape +genMappedShape names = + oneof + [ ShapeRecord + <$> genName + <*> elements [RejectUnknown, IgnoreUnknown] + <*> smallList (genWireField names) + , ShapeEnum <$> smallList (WireEnum <$> genName <*> genAdversarialText <*> pure noLoc) + , ShapeUnion + <$> (TaggedObject <$> genAdversarialText <*> genAdversarialText <*> elements [RejectUnknown, IgnoreUnknown]) + <*> smallList (WireArm <$> genName <*> genAdversarialText <*> genMaybe (genTypeExpr names) <*> pure noLoc) + ] + +genWireField :: [Name] -> Gen WireField +genWireField names = + WireField + <$> genName + <*> genAdversarialText + <*> genTypeExpr names + <*> elements [PRequired, POptional] + <*> genMaybe genOnMissing + <*> pure noLoc + +genTypeExpr :: [Name] -> Gen TypeExpr +genTypeExpr names = sized (go . min 3) + where + go 0 = base + go depth = + frequency + [ (4, base) + , (1, TOptional <$> go (depth - 1)) + , (1, TList <$> go (depth - 1)) + , (1, TMap <$> go (depth - 1)) + ] + base = elements ([TText, TInt, TBool, TNatural, TTime, TJson] ++ map TRef names) + +genOnMissing :: Gen OnMissing +genOnMissing = + oneof + [ pure OmNull + , OmText <$> genAdversarialText + , OmInt <$> choose (-10, 10) + , OmBool <$> arbitrary + , pure OmEmptyList + , pure OmEmptyMap + , OmCtor <$> genName + ] + +genSpec :: Gen Spec +genSpec = do + contextName <- genWire + moduleRoot <- genMaybe genModuleRoot + layout <- genMaybe (elements [GeneratedPrefix, CollocatedLeaf]) + ids <- smallList genId + enums <- smallList genEnum + rules <- smallList genRule + mapped <- genMappedDecls + nodes <- smallList genNode + pure (Spec contextName moduleRoot layout ids enums rules mapped nodes) where genNode = oneof diff --git a/test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs b/test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs new file mode 100644 --- /dev/null +++ b/test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Conformance.CodecCompare.Historical ( + historicalArtifactInfoCodec, + generatedEquivalentArtifactInfoCodec, +) +where + +import Conformance.Structural.Domain qualified as Domain +import Data.Aeson (Value (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) +import Data.Aeson.Types (Parser, parseEither) +import Data.Text (Text) +import Data.Text qualified as T +import Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec +import Keiro.Dsl.CodecCompare (HistoricalCodec (..)) + +historicalArtifactInfoCodec :: HistoricalCodec Domain.ArtifactInfo +historicalArtifactInfoCodec = + HistoricalCodec + { hcIdentity = "conformance.structural.ArtifactInfo.aeson" + , hcVersion = "legacy-v3" + , hcEncode = encodeArtifactInfo + , hcDecode = either (Left . T.pack) Right . parseEither parseArtifactInfo + } + +{- | Acceptance control: this stands in for the historical codec after its two +migration quirks have been removed. Keeping it beside the genuinely +historical codec lets the consumer-level test exercise the runner's success +exit condition as well as its refusal path. +-} +generatedEquivalentArtifactInfoCodec :: HistoricalCodec Domain.ArtifactInfo +generatedEquivalentArtifactInfoCodec = + HistoricalCodec + { hcIdentity = "conformance.structural.ArtifactInfo.generated-equivalent" + , hcVersion = "cutover-v4" + , hcEncode = GeneratedCodec.encodeArtifactInfoMapped + , hcDecode = GeneratedCodec.decodeArtifactInfoMapped + } + +encodeArtifactInfo :: Domain.ArtifactInfo -> Value +encodeArtifactInfo value = + object + ( [ "artifact_key" .= value.artifactKey + , "display_name" .= value.displayName + , "artifact_kind" .= encodeArtifactKind value.artifactKind + , "location" .= encodeLocation value.location + , "metadata" .= object ["note" .= value.metadata.note] + , "active" .= value.active + , "tags" .= value.tags + ] + <> maybe [] (pure . ("artifact_hash" .=)) value.artifactHash + ) + +encodeArtifactKind :: Domain.ArtifactKind -> Value +encodeArtifactKind Domain.Guide = String "guide" +encodeArtifactKind Domain.Reference = String "reference" + +encodeLocation :: Domain.ArtifactLocation -> Value +encodeLocation location = case location of + Domain.LocalFile payload -> tagged "local_file" (Just payload) + Domain.LocalDir payload -> tagged "local_dir" (Just payload) + Domain.RepoPath payload -> tagged "repo_path" (Just payload) + Domain.LocUrl payload -> tagged "url" (Just payload) + Domain.Canonical -> tagged "Canonical" Nothing + where + tagged :: Text -> Maybe Text -> Value + tagged tag payload = object (["tag" .= tag] <> maybe [] (pure . ("contents" .=)) payload) + +parseArtifactInfo :: Value -> Parser Domain.ArtifactInfo +parseArtifactInfo = withObject "historical ArtifactInfo" $ \value -> + Domain.ArtifactInfo + <$> value .: "artifact_key" + <*> value .: "display_name" + <*> value .:? "artifact_hash" + <*> (value .:? "artifact_kind" >>= maybe (pure Domain.Guide) parseArtifactKind) + <*> (value .: "location" >>= parseLocation) + <*> (value .: "metadata" >>= parseMetadata) + <*> value .:? "active" .!= False + <*> value .:? "tags" .!= [] + +parseArtifactKind :: Value -> Parser Domain.ArtifactKind +parseArtifactKind = withText "historical ArtifactKind" $ \value -> case value of + "guide" -> pure Domain.Guide + "reference" -> pure Domain.Reference + _ -> fail "unknown historical artifact kind" + +parseLocation :: Value -> Parser Domain.ArtifactLocation +parseLocation = withObject "historical ArtifactLocation" $ \value -> do + tag <- value .: "tag" :: Parser Text + case tag of + "local_file" -> Domain.LocalFile <$> value .: "contents" + "local_dir" -> Domain.LocalDir <$> value .: "contents" + "repo_path" -> Domain.RepoPath <$> value .: "contents" + "url" -> Domain.LocUrl <$> value .: "contents" + "Canonical" -> pure Domain.Canonical + _ -> fail "unknown historical artifact location" + +parseMetadata :: Value -> Parser Domain.ArtifactMetadata +parseMetadata = withObject "historical ArtifactMetadata" $ \value -> + Domain.ArtifactMetadata <$> value .:? "note" diff --git a/test/conformance-codec-compare/Main.hs b/test/conformance-codec-compare/Main.hs new file mode 100644 --- /dev/null +++ b/test/conformance-codec-compare/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Main (main) where + +import Conformance.CodecCompare.Historical (generatedEquivalentArtifactInfoCodec, historicalArtifactInfoCodec) +import Control.Monad (unless) +import Data.Text qualified as T +import Generated.StructuralConformance.Structural.CodecCompare.ArtifactInfo (compareWithHistorical) +import Keiro.Dsl.CodecCompare +import System.Exit (exitFailure) + +main :: IO () +main = do + report <- compareWithHistorical historicalArtifactInfoCodec corpusPath + missingArm <- compareWithHistorical historicalArtifactInfoCodec missingArmPath + parityReport <- compareWithHistorical generatedEquivalentArtifactInfoCodec parityCorpusPath + let differences = + [ difference + | observation <- crObservations report + , RequiresVersionWork difference <- [classifiedVerdict observation] + ] + assertions = + [ ("comparison has explicit differences", not (null differences)) + , ("omitted key is not parity", any isArtifactHashDifference differences) + , ("legacy union tag is not parity", any isCanonicalTagDifference differences) + , ("historical corpus is valid", null (crInputIssues report)) + , ("historical and typed branch coverage is complete", null (crCoverageGaps report)) + , ("differences make the report fail", not (reportSucceeded report)) + , ("authority framing is mandatory", "MIGRATION EVIDENCE ONLY" `T.isInfixOf` renderCompareReport report) + , ("missing canonical arm is a coverage gap", any isCanonicalGap (crCoverageGaps missingArm)) + , ("removing the historical quirks yields parity", reportSucceeded parityReport) + , ("parity retains authority framing", "MIGRATION EVIDENCE ONLY" `T.isInfixOf` renderCompareReport parityReport) + ] + mapM_ (\(label, ok) -> putStrLn ((if ok then "PASS " else "FAIL ") <> label)) assertions + unless (all snd assertions) exitFailure + where + corpusPath = "test/conformance-codec-compare/fixtures/artifact-info" + missingArmPath = "test/conformance-codec-compare/fixtures/missing-arm" + parityCorpusPath = "test/conformance-codec-compare/fixtures/generated-parity" + +isArtifactHashDifference :: ComparisonDifference -> Bool +isArtifactHashDifference difference = case difference of + EncodedValueDifference (JsonPointer pointer) _ _ -> pointer == "/artifact_hash" + _ -> False + +isCanonicalTagDifference :: ComparisonDifference -> Bool +isCanonicalTagDifference (GeneratedDecodeRejected reason) = "unknown ArtifactLocation union tag" `T.isInfixOf` reason +isCanonicalTagDifference _ = False + +isCanonicalGap :: CoverageGap -> Bool +isCanonicalGap gap = case cgKind gap of + UnionArm arm -> arm == "canonical" + _ -> False diff --git a/test/conformance-coldstart/Generated/Billing/ReplayAudit.hs b/test/conformance-coldstart/Generated/Billing/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-coldstart/Generated/Billing/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.Billing.ReplayAudit (auditTargets) where + +import Generated.Billing.Subscription.EventStream qualified as Subscription +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Subscription.subscriptionEventStream + , category = Stream.categoryText Subscription.subscriptionCategory + , mkStream = streamInCategory (Stream.categoryText Subscription.subscriptionCategory) + } + ] diff --git a/test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs b/test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs --- a/test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs +++ b/test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. @@ -6,7 +8,7 @@ import Billing.Subscription.Holes (subscriptionTransducer) import Generated.Billing.Subscription.Codec (encodeSubscriptionEvent, parseSubscriptionEvent, subscriptionCodec) import Generated.Billing.Subscription.Domain -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) {- | (label, passed). A driver runs these and exits non-zero on any False, @@ -21,6 +23,7 @@ , ("golden round-trip: SubscriptionCancelled", roundTrips sampleEventSubscriptionCancelled) , ("accepts ActivateSubscription from SubscriptionInactive", acceptActivateSubscription) ] + ++ forwardReplayActivateSubscription roundTrips :: SubscriptionEvent -> Bool roundTrips e = parseSubscriptionEvent (eventType subscriptionCodec e) (encodeSubscriptionEvent e) == Right e @@ -36,3 +39,23 @@ case step subscriptionTransducer (SubscriptionInactive, initialSubscriptionRegs) ((ActivateSubscription (ActivateSubscriptionData (SubscriptionId "sample") (CustomerId "sample") Paid))) of Just (v, _, _) -> v == SubscriptionActive Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayActivateSubscription :: [(String, Bool)] +forwardReplayActivateSubscription = + case step subscriptionTransducer (SubscriptionInactive, initialSubscriptionRegs) ((ActivateSubscription (ActivateSubscriptionData (SubscriptionId "sample") (CustomerId "sample") Paid))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseSubscriptionEvent (eventType subscriptionCodec event) (encodeSubscriptionEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither subscriptionTransducer (SubscriptionInactive, initialSubscriptionRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register plan", (replayRegs ! #plan) == (forwardRegs ! #plan)) + , (prefix <> "register subscriptionState", (replayRegs ! #subscriptionState) == (forwardRegs ! #subscriptionState)) + ] + where + prefix = "forward/replay equality: ActivateSubscription from SubscriptionInactive -- " diff --git a/test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs b/test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. + +{- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. + +Deploy workers before producers when raising its schema version. Do not +adopt this codec on a non-empty bare-payload queue without draining it +(or supplying a transitional codec), or in-flight messages will +dead-letter. This is telemetry-neutral: +docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns +spans and acknowledgement vocabulary. +-} +module Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkPayloadCodec, reservationWorkJobCodec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem, encodeReservationWorkItem, parseReservationWorkItem) +import Keiro.Codec (Codec (..), EventType (..)) +import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec) + +reservationWorkPayloadCodec :: Codec ReservationWorkItem +reservationWorkPayloadCodec = + Codec + { eventTypes = EventType "ReservationWorkItem" :| [] + , eventType = \_ -> EventType "ReservationWorkItem" + , schemaVersion = 1 + , encode = encodeReservationWorkItem + , decode = \_ -> parseReservationWorkItem + , upcasters = [] + } + +reservationWorkJobCodec :: JobCodec ReservationWorkItem +reservationWorkJobCodec = keiroJobCodec reservationWorkPayloadCodec diff --git a/test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs b/test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs --- a/test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs +++ b/test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs @@ -12,11 +12,9 @@ import Effectful (Eff) import Generated.HospitalCapacity.Reservation_work.Queue ( ReservationWorkItem, - encodeReservationWorkItem, - parseReservationWorkItem, ) +import Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkJobCodec) import Generated.HospitalCapacity.Reservation_work.QueuePolicy (retryPolicy) -import Keiro.PGMQ.Codec (mkJobCodec) import Keiro.PGMQ.Job (Job (..), JobOutcome (..)) import Keiro.PGMQ.Runtime (queueRef) @@ -26,10 +24,7 @@ Job { jobName = "reservation-work" , jobQueue = queueRef "hospital_capacity.reservation_work" - , jobCodec = - mkJobCodec - encodeReservationWorkItem - parseReservationWorkItem + , jobCodec = reservationWorkJobCodec , jobPolicy = retryPolicy } diff --git a/test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs b/test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs --- a/test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs +++ b/test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. @@ -5,7 +7,7 @@ import Generated.TransferRouting.Hospital.Codec (encodeHospitalEvent, hospitalCodec, parseHospitalEvent) import Generated.TransferRouting.Hospital.Domain -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer) import Keiro.Codec (eventType) import TransferRouting.Hospital.Holes (hospitalTransducer) @@ -20,15 +22,34 @@ , ("golden round-trip: AcceptedTransferNeedRouted", roundTrips sampleEventAcceptedTransferNeedRouted) , ("accepts RouteAcceptedTransferNeed from HospitalAccepting", acceptRouteAcceptedTransferNeed) ] + ++ forwardReplayRouteAcceptedTransferNeed roundTrips :: HospitalEvent -> Bool roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e sampleEventAcceptedTransferNeedRouted :: HospitalEvent -sampleEventAcceptedTransferNeedRouted = (AcceptedTransferNeedRouted (AcceptedTransferNeedRoutedData "sample" "sample")) +sampleEventAcceptedTransferNeedRouted = (AcceptedTransferNeedRouted (AcceptedTransferNeedRoutedData "sample-transferNeedId" "sample-hospitalId")) acceptRouteAcceptedTransferNeed :: Bool acceptRouteAcceptedTransferNeed = - case step hospitalTransducer (HospitalAccepting, initialHospitalRegs) ((RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample" "sample"))) of + case step hospitalTransducer (HospitalAccepting, initialHospitalRegs) ((RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample-transferNeedId" "sample-hospitalId"))) of Just (v, _, _) -> v == HospitalAccepting Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayRouteAcceptedTransferNeed :: [(String, Bool)] +forwardReplayRouteAcceptedTransferNeed = + case step hospitalTransducer (HospitalAccepting, initialHospitalRegs) ((RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample-transferNeedId" "sample-hospitalId"))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, _forwardRegs, emitted) -> + case mapM (\event -> parseHospitalEvent (eventType hospitalCodec event) (encodeHospitalEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither hospitalTransducer (HospitalAccepting, initialHospitalRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, _replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + ] + where + prefix = "forward/replay equality: RouteAcceptedTransferNeed from HospitalAccepting -- " diff --git a/test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs b/test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.TransferRouting.ReplayAudit (auditTargets) where + +import Generated.TransferRouting.Hospital.EventStream qualified as Hospital +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Hospital.hospitalEventStream + , category = Stream.categoryText Hospital.hospitalCategory + , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory) + } + ] diff --git a/test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs b/test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.SurgeDemo.ReplayAudit (auditTargets) where + +import Generated.SurgeDemo.Hospital.EventStream qualified as Hospital +import Generated.SurgeDemo.Surge.EventStream qualified as Surge +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Hospital.hospitalEventStream + , category = Stream.categoryText Hospital.hospitalCategory + , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory) + } + , SomeAuditTarget + AuditTarget + { eventStream = Surge.surgeEventStream + , category = Stream.categoryText Surge.surgeCategory + , mkStream = streamInCategory (Stream.categoryText Surge.surgeCategory) + } + ] diff --git a/test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs b/test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. + +{- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. + +Deploy workers before producers when raising its schema version. Do not +adopt this codec on a non-empty bare-payload queue without draining it +(or supplying a transitional codec), or in-flight messages will +dead-letter. This is telemetry-neutral: +docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns +spans and acknowledgement vocabulary. +-} +module Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkPayloadCodec, reservationWorkJobCodec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem, encodeReservationWorkItem, parseReservationWorkItem) +import Keiro.Codec (Codec (..), EventType (..)) +import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec) + +reservationWorkPayloadCodec :: Codec ReservationWorkItem +reservationWorkPayloadCodec = + Codec + { eventTypes = EventType "ReservationWorkItem" :| [] + , eventType = \_ -> EventType "ReservationWorkItem" + , schemaVersion = 1 + , encode = encodeReservationWorkItem + , decode = \_ -> parseReservationWorkItem + , upcasters = [] + } + +reservationWorkJobCodec :: JobCodec ReservationWorkItem +reservationWorkJobCodec = keiroJobCodec reservationWorkPayloadCodec diff --git a/test/conformance-queue-runtime/Main.hs b/test/conformance-queue-runtime/Main.hs --- a/test/conformance-queue-runtime/Main.hs +++ b/test/conformance-queue-runtime/Main.hs @@ -8,10 +8,10 @@ import Control.Monad (unless) import Data.Text (Text) -import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem (..), encodeReservationWorkItem, groupKeyFor, parseReservationWorkItem) +import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem (..), groupKeyFor) +import Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkJobCodec) import Generated.HospitalCapacity.Reservation_work.QueuePolicy (jobOrdering, jobOutcomeFor, jobTuningFor, queueProvision, retryPolicy) import Keiro.Dsl.Validate (derivedQueueTrio) -import Keiro.PGMQ.Codec (mkJobCodec) import Keiro.PGMQ.Job (Job (..), JobOrdering (..), JobOutcome (..), JobTuning (..), RetryPolicy (..), defaultJobTuning, queueProvisionConfigs) import Keiro.PGMQ.Runtime (QueueRef (..), queueRef) import Pgmq.Config qualified as Config @@ -37,7 +37,7 @@ Job { jobName = "reservation-work" , jobQueue = queueRef "hospital_capacity.reservation_work" - , jobCodec = mkJobCodec encodeReservationWorkItem parseReservationWorkItem + , jobCodec = reservationWorkJobCodec , jobPolicy = retryPolicy } provisionOk = case queueProvisionConfigs queueProvision job of diff --git a/test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs b/test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. + +{- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. + +Deploy workers before producers when raising its schema version. Do not +adopt this codec on a non-empty bare-payload queue without draining it +(or supplying a transitional codec), or in-flight messages will +dead-letter. This is telemetry-neutral: +docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns +spans and acknowledgement vocabulary. +-} +module Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkPayloadCodec, reservationWorkJobCodec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem, encodeReservationWorkItem, parseReservationWorkItem) +import Keiro.Codec (Codec (..), EventType (..)) +import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec) + +reservationWorkPayloadCodec :: Codec ReservationWorkItem +reservationWorkPayloadCodec = + Codec + { eventTypes = EventType "ReservationWorkItem" :| [] + , eventType = \_ -> EventType "ReservationWorkItem" + , schemaVersion = 1 + , encode = encodeReservationWorkItem + , decode = \_ -> parseReservationWorkItem + , upcasters = [] + } + +reservationWorkJobCodec :: JobCodec ReservationWorkItem +reservationWorkJobCodec = keiroJobCodec reservationWorkPayloadCodec diff --git a/test/conformance-queue/Main.hs b/test/conformance-queue/Main.hs --- a/test/conformance-queue/Main.hs +++ b/test/conformance-queue/Main.hs @@ -7,16 +7,29 @@ module Main (main) where import Control.Monad (unless) +import Data.Aeson (object, (.=)) import Generated.HospitalCapacity.Reservation_work.Queue +import Generated.HospitalCapacity.Reservation_work.QueueCodec (reservationWorkJobCodec) +import Keiro.PGMQ.Codec (JobCodec (..)) import System.Exit (exitFailure) main :: IO () main = do let sample = ReservationWorkItem "rsv-1" "hsp-1" "cmd-1" True roundTrips = parseReservationWorkItem (encodeReservationWorkItem sample) == Right sample + envelope = + object + [ "v" .= (1 :: Int) + , "t" .= ("ReservationWorkItem" :: String) + , "data" .= encodeReservationWorkItem sample + ] + envelopeOk = + encodeJob reservationWorkJobCodec sample == envelope + && decodeJob reservationWorkJobCodec envelope == Right sample physicalOk = queuePhysical == "hospital_capacity_reservation_work" groupKeyOk = groupKeyFor sample == "rsv-1" putStrLn ((if roundTrips then "PASS " else "FAIL ") <> "Job codec round-trip") + putStrLn ((if envelopeOk then "PASS " else "FAIL ") <> "versioned {v,t,data} job envelope") putStrLn ((if physicalOk then "PASS " else "FAIL ") <> "captured physical name") putStrLn ((if groupKeyOk then "PASS " else "FAIL ") <> "raw FIFO group-key projection") - unless (roundTrips && physicalOk && groupKeyOk) exitFailure + unless (roundTrips && envelopeOk && physicalOk && groupKeyOk) exitFailure diff --git a/test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs b/test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.ReplayDivergence.Note.Codec ( + noteCodec, + parseNoteEvent, + encodeNoteEvent, +) where + +import Data.Aeson (Value, object, withObject, (.:), (.=)) +import Data.Aeson.Types (Parser, parseEither) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Generated.ReplayDivergence.Note.Domain +import Keiro.Codec (Codec (..), EventType (..)) + +noteCodec :: Codec NoteEvent +noteCodec = + Codec + { eventTypes = EventType "NoteWritten" :| [] + , eventType = \case + NoteWritten{} -> EventType "NoteWritten" + , schemaVersion = 1 + , encode = encodeNoteEvent + , decode = parseNoteEvent + , upcasters = [] + } + +encodeNoteEvent :: NoteEvent -> Value +encodeNoteEvent = \case + NoteWritten payload -> + object + [ "kind" .= ("NoteWritten" :: Text) + , "noteText" .= payload.noteText + , "echo" .= payload.echo + ] + +parseNoteEvent :: EventType -> Value -> Either Text NoteEvent +parseNoteEvent (EventType tag) = mapLeftText . parseEither (withObject "NoteEvent" go) + where + go o = do + case tag of + "NoteWritten" -> + NoteWritten <$> (NoteWrittenData <$> o .: "noteText" <*> o .: "echo") + _ -> fail "unknown event type" + +mapLeftText :: Either String b -> Either Text b +mapLeftText = either (Left . T.pack) Right diff --git a/test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs b/test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.ReplayDivergence.Note.Domain where + +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Keiki.Core (RegFile (..)) +import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll) + +data NoteVertex = NoteEmpty | NoteRecorded + deriving stock (Generic, Eq, Ord, Show, Enum, Bounded) + +data WriteNoteData = WriteNoteData + { noteText :: !Text + , echo :: !Text + } + deriving stock (Generic, Eq, Show) + +data NoteCommand = WriteNote !WriteNoteData + deriving stock (Generic, Eq, Show) + +data NoteWrittenData = NoteWrittenData + { noteText :: !Text + , echo :: !Text + } + deriving stock (Generic, Eq, Show) + +data NoteEvent = NoteWritten !NoteWrittenData + deriving stock (Generic, Eq, Show) + +type NoteRegs = + '[ '("note", Text) + ] + +initialNoteRegs :: RegFile NoteRegs +initialNoteRegs = + RCons (Proxy @"note") "" RNil + +$(deriveAggregateCtorsAll ''NoteCommand ''NoteRegs) + +$(deriveWireCtorsAll ''NoteEvent) diff --git a/test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs b/test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs @@ -0,0 +1,44 @@ +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.ReplayDivergence.Note.EventStream ( + noteCategory, + noteEventStream, + noteEventStreamDef, + NoteEventStream, + NoteEventStreamDef, +) where + +import Generated.ReplayDivergence.Note.Codec (noteCodec) +import Generated.ReplayDivergence.Note.Domain +import Keiki.Core (HsPred) +import Keiro.EventStream (EventStream (..), SnapshotPolicy (..)) +import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow) +import Keiro.Stream qualified as Stream +import ReplayDivergence.Note.Holes (noteTransducer) + +-- The validated aggregate stream category (hole-kind 5: referenced, never retyped). +-- Entity streams are '-' via Keiro.Stream.entityStream. +-- categoryUnsafe is safe here because this generated literal passed the DSL category proof. +noteCategory :: Stream.StreamCategory a +noteCategory = Stream.categoryUnsafe "note" + +type NoteEventStreamDef = + EventStream (HsPred NoteRegs NoteCommand) NoteRegs NoteVertex NoteCommand NoteEvent + +type NoteEventStream = + ValidatedEventStream (HsPred NoteRegs NoteCommand) NoteRegs NoteVertex NoteCommand NoteEvent + +noteEventStreamDef :: NoteEventStreamDef +noteEventStreamDef = + EventStream + { transducer = noteTransducer + , initialState = NoteEmpty + , initialRegisters = initialNoteRegs + , eventCodec = noteCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Never + , stateCodec = Nothing + } + +noteEventStream :: NoteEventStream +noteEventStream = + mkEventStreamOrThrow "Note" noteEventStreamDef diff --git a/test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs b/test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.ReplayDivergence.Note.Harness (harnessAssertions) where + +import Generated.ReplayDivergence.Note.Codec (encodeNoteEvent, noteCodec, parseNoteEvent) +import Generated.ReplayDivergence.Note.Domain +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) +import Keiro.Codec (eventType) +import ReplayDivergence.Note.Holes (noteTransducer) + +{- | (label, passed). A driver runs these and exits non-zero on any False, +naming the failing assertion. Filling a hole wrongly turns a specific +entry False; the scaffold cannot. +-} +harnessAssertions :: [(String, Bool)] +harnessAssertions = + [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions noteTransducer)) + , ("clock-free: spec samples no wall clock", True) + , ("golden round-trip: NoteWritten", roundTrips sampleEventNoteWritten) + , ("accepts WriteNote from NoteEmpty", acceptWriteNote) + ] + ++ forwardReplayWriteNote + +roundTrips :: NoteEvent -> Bool +roundTrips e = parseNoteEvent (eventType noteCodec e) (encodeNoteEvent e) == Right e + +sampleEventNoteWritten :: NoteEvent +sampleEventNoteWritten = (NoteWritten (NoteWrittenData "sample-noteText" "sample-echo")) + +acceptWriteNote :: Bool +acceptWriteNote = + case step noteTransducer (NoteEmpty, initialNoteRegs) ((WriteNote (WriteNoteData "sample-noteText" "sample-echo"))) of + Just (v, _, _) -> v == NoteRecorded + Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayWriteNote :: [(String, Bool)] +forwardReplayWriteNote = + case step noteTransducer (NoteEmpty, initialNoteRegs) ((WriteNote (WriteNoteData "sample-noteText" "sample-echo"))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseNoteEvent (eventType noteCodec event) (encodeNoteEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither noteTransducer (NoteEmpty, initialNoteRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register note", (replayRegs ! #note) == (forwardRegs ! #note)) + ] + where + prefix = "forward/replay equality: WriteNote from NoteEmpty -- " diff --git a/test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs b/test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs @@ -0,0 +1,2 @@ +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.ReplayDivergence.Note.Projection () where diff --git a/test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs b/test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.ReplayDivergence.ReplayAudit (auditTargets) where + +import Generated.ReplayDivergence.Note.EventStream qualified as Note +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Note.noteEventStream + , category = Stream.categoryText Note.noteCategory + , mkStream = streamInCategory (Stream.categoryText Note.noteCategory) + } + ] diff --git a/test/conformance-replay/Main.hs b/test/conformance-replay/Main.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/Main.hs @@ -0,0 +1,19 @@ +{- | Conformance driver for the replay-divergence mutation fixture. It prints +every generated assertion and exits non-zero when any assertion fails, so the +mutation script can distinguish the new forward/replay register check from all +pre-existing checks. +-} +module Main (main) where + +import Control.Monad (forM_, unless) +import Generated.ReplayDivergence.Note.Harness (harnessAssertions) +import System.Exit (exitFailure) + +main :: IO () +main = do + forM_ harnessAssertions $ \(label, ok) -> + putStrLn ((if ok then "PASS " else "FAIL ") <> label) + let failed = [label | (label, ok) <- harnessAssertions, not ok] + unless (null failed) $ do + putStrLn ("harness: " <> show (length failed) <> " assertion(s) failed") + exitFailure diff --git a/test/conformance-replay/ReplayDivergence/Note/Holes.hs b/test/conformance-replay/ReplayDivergence/Note/Holes.hs new file mode 100644 --- /dev/null +++ b/test/conformance-replay/ReplayDivergence/Note/Holes.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE TypeApplications #-} + +-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never +-- overwrites it. Fill the transducer body (and any other holes) against the +-- generated signatures, then run the harness to confirm behaviour. +module ReplayDivergence.Note.Holes ( + noteTransducer, + dishonestWireNoteWritten, +) where + +import Data.Text (Text) +import Generated.ReplayDivergence.Note.Domain +import Keiki.Builder ((=:)) +import Keiki.Builder qualified as B +import Keiki.Core (HsPred, SymTransducer, WireCtor (..)) + +-- HOLE: the transducer body. Reproduce the structure below, replacing each +-- `-- HOLE` line with the keiki symbolic operators it describes. +noteTransducer :: + SymTransducer + (HsPred NoteRegs NoteCommand) + NoteRegs + NoteVertex + NoteCommand + NoteEvent +noteTransducer = + B.buildTransducer NoteEmpty initialNoteRegs isTerminal do + B.from NoteEmpty do + B.onCmd inCtorWriteNote $ \d -> B.do + B.slot @"note" =: d.noteText + B.emit + emitWire + NoteWrittenTermFields + { noteText = d.noteText + , echo = d.echo + } + B.goto NoteRecorded + where + isTerminal = \case + NoteRecorded -> True + _ -> False + +-- The honest generated wire ctor sits behind an indirection that the mutation +-- test changes in one line. +emitWire :: WireCtor NoteEvent (Text, (Text, ())) +emitWire = wireNoteWritten + +-- This dormant dishonest ctor copies echo into both event fields. Unlike a +-- simple swap, the rewrite is idempotent: replay's event rebuild check accepts +-- the observed event, then the recovered command writes echo into the note +-- register. Only the generated forward/replay register comparison catches it. +dishonestWireNoteWritten :: WireCtor NoteEvent (Text, (Text, ())) +dishonestWireNoteWritten = + wireNoteWritten + { wcBuild = wcBuild wireNoteWritten . duplicateEcho + } + +duplicateEcho :: (Text, (Text, ())) -> (Text, (Text, ())) +duplicateEcho (_noteText, (echo, ())) = (echo, (echo, ())) diff --git a/test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs b/test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.IncidentPaging.ReplayAudit (auditTargets) where + +import Generated.IncidentPaging.Page.EventStream qualified as Page +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Page.pageEventStream + , category = Stream.categoryText Page.pageCategory + , mkStream = streamInCategory (Stream.categoryText Page.pageCategory) + } + ] diff --git a/test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs b/test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module SkelAggregate.Generated.MyService.ReplayAudit (auditTargets) where + +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream +import SkelAggregate.Generated.MyService.Thing.EventStream qualified as Thing + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Thing.thingEventStream + , category = Stream.categoryText Thing.thingCategory + , mkStream = streamInCategory (Stream.categoryText Thing.thingCategory) + } + ] diff --git a/test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs b/test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs --- a/test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs +++ b/test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. module SkelAggregate.Generated.MyService.Thing.Harness (harnessAssertions) where -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) import SkelAggregate.Generated.MyService.Thing.Codec (encodeThingEvent, parseThingEvent, thingCodec) import SkelAggregate.Generated.MyService.Thing.Domain @@ -20,6 +22,7 @@ , ("golden round-trip: ThingCompleted", roundTrips sampleEventThingCompleted) , ("accepts DoThing from ThingPending", acceptDoThing) ] + ++ forwardReplayDoThing roundTrips :: ThingEvent -> Bool roundTrips e = parseThingEvent (eventType thingCodec e) (encodeThingEvent e) == Right e @@ -32,3 +35,23 @@ case step thingTransducer (ThingPending, initialThingRegs) ((DoThing (DoThingData (ThingId "sample") 0))) of Just (v, _, _) -> v == ThingDone Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayDoThing :: [(String, Bool)] +forwardReplayDoThing = + case step thingTransducer (ThingPending, initialThingRegs) ((DoThing (DoThingData (ThingId "sample") 0))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseThingEvent (eventType thingCodec event) (encodeThingEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither thingTransducer (ThingPending, initialThingRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register thingId", (replayRegs ! #thingId) == (forwardRegs ! #thingId)) + , (prefix <> "register state", (replayRegs ! #state) == (forwardRegs ! #state)) + ] + where + prefix = "forward/replay equality: DoThing from ThingPending -- " diff --git a/test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs b/test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs --- a/test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs +++ b/test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. module SkelProcess.Generated.MyService.Hospital.Harness (harnessAssertions) where -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer) import Keiro.Codec (eventType) import SkelProcess.Generated.MyService.Hospital.Codec (encodeHospitalEvent, hospitalCodec, parseHospitalEvent) import SkelProcess.Generated.MyService.Hospital.Domain @@ -20,6 +22,7 @@ , ("golden round-trip: SurgeActivated", roundTrips sampleEventSurgeActivated) , ("accepts ActivateSurge from HospitalOperational", acceptActivateSurge) ] + ++ forwardReplayActivateSurge roundTrips :: HospitalEvent -> Bool roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e @@ -32,3 +35,21 @@ case step hospitalTransducer (HospitalOperational, initialHospitalRegs) ((ActivateSurge (ActivateSurgeData (HospitalId "sample")))) of Just (v, _, _) -> v == HospitalSurging Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayActivateSurge :: [(String, Bool)] +forwardReplayActivateSurge = + case step hospitalTransducer (HospitalOperational, initialHospitalRegs) ((ActivateSurge (ActivateSurgeData (HospitalId "sample")))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, _forwardRegs, emitted) -> + case mapM (\event -> parseHospitalEvent (eventType hospitalCodec event) (encodeHospitalEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither hospitalTransducer (HospitalOperational, initialHospitalRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, _replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + ] + where + prefix = "forward/replay equality: ActivateSurge from HospitalOperational -- " diff --git a/test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs b/test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module SkelProcess.Generated.MyService.ReplayAudit (auditTargets) where + +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream +import SkelProcess.Generated.MyService.Hospital.EventStream qualified as Hospital +import SkelProcess.Generated.MyService.Surge.EventStream qualified as Surge + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Surge.surgeEventStream + , category = Stream.categoryText Surge.surgeCategory + , mkStream = streamInCategory (Stream.categoryText Surge.surgeCategory) + } + , SomeAuditTarget + AuditTarget + { eventStream = Hospital.hospitalEventStream + , category = Stream.categoryText Hospital.hospitalCategory + , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory) + } + ] diff --git a/test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs b/test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs --- a/test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs +++ b/test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. module SkelProcess.Generated.MyService.Surge.Harness (harnessAssertions) where -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer) import Keiro.Codec (eventType) import SkelProcess.Generated.MyService.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec) import SkelProcess.Generated.MyService.Surge.Domain @@ -22,24 +24,62 @@ , ("accepts NoteSurgeThreshold from SurgeIdle", acceptNoteSurgeThreshold) , ("accepts MarkSurgeTimerFired from SurgeIdle", acceptMarkSurgeTimerFired) ] + ++ forwardReplayNoteSurgeThreshold + ++ forwardReplayMarkSurgeTimerFired roundTrips :: SurgeEvent -> Bool roundTrips e = parseSurgeEvent (eventType surgeCodec e) (encodeSurgeEvent e) == Right e sampleEventSurgeThresholdNoted :: SurgeEvent -sampleEventSurgeThresholdNoted = (SurgeThresholdNoted (SurgeThresholdNotedData (HospitalId "sample") 0 0 "sample")) +sampleEventSurgeThresholdNoted = (SurgeThresholdNoted (SurgeThresholdNotedData (HospitalId "sample") 0 0 "sample-timerId")) sampleEventSurgeTimerMarked :: SurgeEvent -sampleEventSurgeTimerMarked = (SurgeTimerMarked (SurgeTimerMarkedData (HospitalId "sample") "sample")) +sampleEventSurgeTimerMarked = (SurgeTimerMarked (SurgeTimerMarkedData (HospitalId "sample") "sample-timerId")) acceptNoteSurgeThreshold :: Bool acceptNoteSurgeThreshold = - case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((NoteSurgeThreshold (NoteSurgeThresholdData (HospitalId "sample") 0 0 "sample"))) of + case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((NoteSurgeThreshold (NoteSurgeThresholdData (HospitalId "sample") 0 0 "sample-timerId"))) of Just (v, _, _) -> v == SurgeIdle Nothing -> False acceptMarkSurgeTimerFired :: Bool acceptMarkSurgeTimerFired = - case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((MarkSurgeTimerFired (MarkSurgeTimerFiredData (HospitalId "sample") "sample"))) of + case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((MarkSurgeTimerFired (MarkSurgeTimerFiredData (HospitalId "sample") "sample-timerId"))) of Just (v, _, _) -> v == SurgeFired Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayNoteSurgeThreshold :: [(String, Bool)] +forwardReplayNoteSurgeThreshold = + case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((NoteSurgeThreshold (NoteSurgeThresholdData (HospitalId "sample") 0 0 "sample-timerId"))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, _forwardRegs, emitted) -> + case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, _replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + ] + where + prefix = "forward/replay equality: NoteSurgeThreshold from SurgeIdle -- " + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayMarkSurgeTimerFired :: [(String, Bool)] +forwardReplayMarkSurgeTimerFired = + case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((MarkSurgeTimerFired (MarkSurgeTimerFiredData (HospitalId "sample") "sample-timerId"))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, _forwardRegs, emitted) -> + case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, _replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + ] + where + prefix = "forward/replay equality: MarkSurgeTimerFired from SurgeIdle -- " diff --git a/test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs b/test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. + +{- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. + +Deploy workers before producers when raising its schema version. Do not +adopt this codec on a non-empty bare-payload queue without draining it +(or supplying a transitional codec), or in-flight messages will +dead-letter. This is telemetry-neutral: +docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns +spans and acknowledgement vocabulary. +-} +module SkelQueue.Generated.MyService.Reservation_work.QueueCodec (reservationWorkPayloadCodec, reservationWorkJobCodec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Keiro.Codec (Codec (..), EventType (..)) +import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec) +import SkelQueue.Generated.MyService.Reservation_work.Queue (ReservationWorkItem, encodeReservationWorkItem, parseReservationWorkItem) + +reservationWorkPayloadCodec :: Codec ReservationWorkItem +reservationWorkPayloadCodec = + Codec + { eventTypes = EventType "ReservationWorkItem" :| [] + , eventType = \_ -> EventType "ReservationWorkItem" + , schemaVersion = 1 + , encode = encodeReservationWorkItem + , decode = \_ -> parseReservationWorkItem + , upcasters = [] + } + +reservationWorkJobCodec :: JobCodec ReservationWorkItem +reservationWorkJobCodec = keiroJobCodec reservationWorkPayloadCodec diff --git a/test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs b/test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs --- a/test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs +++ b/test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. module SkelRouter.Generated.MyService.Page.Harness (harnessAssertions) where -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer) import Keiro.Codec (eventType) import SkelRouter.Generated.MyService.Page.Codec (encodePageEvent, pageCodec, parsePageEvent) import SkelRouter.Generated.MyService.Page.Domain @@ -20,15 +22,34 @@ , ("golden round-trip: PageSent", roundTrips sampleEventPageSent) , ("accepts SendPage from PagePending", acceptSendPage) ] + ++ forwardReplaySendPage roundTrips :: PageEvent -> Bool roundTrips e = parsePageEvent (eventType pageCodec e) (encodePageEvent e) == Right e sampleEventPageSent :: PageEvent -sampleEventPageSent = (PageSent (PageSentData "sample" "sample")) +sampleEventPageSent = (PageSent (PageSentData "sample-incidentId" "sample-responderId")) acceptSendPage :: Bool acceptSendPage = - case step pageTransducer (PagePending, initialPageRegs) ((SendPage (SendPageData "sample" "sample"))) of + case step pageTransducer (PagePending, initialPageRegs) ((SendPage (SendPageData "sample-incidentId" "sample-responderId"))) of Just (v, _, _) -> v == PageDelivered Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplaySendPage :: [(String, Bool)] +forwardReplaySendPage = + case step pageTransducer (PagePending, initialPageRegs) ((SendPage (SendPageData "sample-incidentId" "sample-responderId"))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, _forwardRegs, emitted) -> + case mapM (\event -> parsePageEvent (eventType pageCodec event) (encodePageEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither pageTransducer (PagePending, initialPageRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, _replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + ] + where + prefix = "forward/replay equality: SendPage from PagePending -- " diff --git a/test/conformance-skeletons/SkelRouter/Generated/MyService/ReplayAudit.hs b/test/conformance-skeletons/SkelRouter/Generated/MyService/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-skeletons/SkelRouter/Generated/MyService/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module SkelRouter.Generated.MyService.ReplayAudit (auditTargets) where + +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream +import SkelRouter.Generated.MyService.Page.EventStream qualified as Page + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Page.pageEventStream + , category = Stream.categoryText Page.pageCategory + , mkStream = streamInCategory (Stream.categoryText Page.pageCategory) + } + ] diff --git a/test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs b/test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.HospitalCapacity.ReplayAudit (auditTargets) where + +import Generated.HospitalCapacity.Reservation.EventStream qualified as Reservation +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Reservation.reservationEventStream + , category = Stream.categoryText Reservation.reservationCategory + , mkStream = streamInCategory (Stream.categoryText Reservation.reservationCategory) + } + ] diff --git a/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs b/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs --- a/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs +++ b/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs @@ -15,7 +15,7 @@ import GHC.Generics (Generic) import Keiki.Core (RegFile (..)) import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll) -import Keiki.Shape (CanonicalTypeName) +import Keiki.Shape (CanonicalStateShape, CanonicalTypeName) newtype TransferReservationId = TransferReservationId Text deriving stock (Generic, Eq, Ord, Show) @@ -76,6 +76,7 @@ data ReservationVertex = ReservationUnrequested | ReservationHeld | ReservationConfirmed | ReservationExpired | ReservationAdmitted | ReservationReleased deriving stock (Generic, Eq, Ord, Show, Enum, Bounded) deriving anyclass (ToJSON, FromJSON) +instance CanonicalStateShape ReservationVertex instance CanonicalTypeName ReservationVertex data RequestTransferReservationData = RequestTransferReservationData diff --git a/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs b/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs --- a/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs +++ b/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs @@ -15,7 +15,7 @@ import Keiki.Core (HsPred) import Keiro.EventStream (EventStream (..), SnapshotPolicy (..)) import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow) -import Keiro.Snapshot.Codec (defaultStateCodec) +import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint) import Keiro.Stream qualified as Stream -- The validated aggregate stream category (hole-kind 5: referenced, never retyped). @@ -39,7 +39,15 @@ , eventCodec = reservationCodec , resolveStreamName = Stream.streamName , snapshotPolicy = Every 100 - , stateCodec = Just (defaultStateCodec 1) + , -- The snapshot discriminator composes: the spec's state-codec version (bump it + -- in the spec's `state-codec version=` clause), keiki's register and + -- control-state shape hashes, and this fold fingerprint derived from the + -- spec's transition surface (guards, writes, emits, states, register + -- initials, referenced rules). Spec-visible fold changes invalidate old + -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes + -- module are invisible here: bump `state-codec version=` manually or old + -- snapshots will be served stale. + stateCodec = Just (withFoldFingerprint "2367ef6fadf0e751" (defaultStateCodec 1)) } reservationSnapshotFixture :: (Int, Text) diff --git a/test/conformance-snapshot/Main.hs b/test/conformance-snapshot/Main.hs --- a/test/conformance-snapshot/Main.hs +++ b/test/conformance-snapshot/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Main (main) where @@ -6,9 +7,9 @@ import Control.Exception (evaluate) import Control.Monad (unless) import Data.Proxy (Proxy (..)) -import Generated.HospitalCapacity.Reservation.Domain (ReservationRegs) +import Generated.HospitalCapacity.Reservation.Domain (ReservationRegs, ReservationVertex) import Generated.HospitalCapacity.Reservation.EventStream (reservationEventStream, reservationEventStreamDef, reservationSnapshotFixture) -import Keiki.Shape (regFileShapeHash) +import Keiki.Shape qualified as Shape import Keiro.EventStream (EventStream (..), SnapshotPolicy (..), StateCodec (..)) import System.Exit (exitFailure) @@ -23,7 +24,10 @@ let (fixtureVersion, fixtureHash) = reservationSnapshotFixture versionOk = stateCodecVersion liveCodec == fixtureVersion hashOk = shapeHash liveCodec == fixtureHash - hashDerived = shapeHash liveCodec == regFileShapeHash (Proxy @ReservationRegs) + hashDerived = shapeHash liveCodec == Shape.regFileShapeHash (Proxy @ReservationRegs) + stateShapeDerived = + stateShapeHash liveCodec + == Shape.stateShapeHash (Proxy @ReservationVertex) <> ";fold=2367ef6fadf0e751" policyOk = case snapshotPolicy reservationEventStreamDef of Every interval -> interval == 100 _ -> False @@ -31,11 +35,12 @@ roundTripOk = case decode liveCodec encoded of Left _ -> False Right decoded -> encode liveCodec decoded == encoded - checks = [versionOk, hashOk, hashDerived, policyOk, roundTripOk] + checks = [versionOk, hashOk, hashDerived, stateShapeDerived, policyOk, roundTripOk] putStrLn ("live snapshot shape hash: " <> show (shapeHash liveCodec)) putStrLn ("codec version matches captured fixture: " <> show versionOk) putStrLn ("shape hash matches captured fixture: " <> show hashOk) putStrLn ("shape hash matches live regFileShapeHash: " <> show hashDerived) + putStrLn ("state shape and fold fingerprint match live derivation: " <> show stateShapeDerived) putStrLn ("snapshot policy is Every 100: " <> show policyOk) putStrLn ("initial snapshot JSON round-trips: " <> show roundTripOk) unless (and checks) exitFailure diff --git a/test/conformance-structural/Conformance/Structural/Bindings.hs b/test/conformance-structural/Conformance/Structural/Bindings.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Conformance/Structural/Bindings.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Conformance.Structural.Bindings ( + artifactInfoBinding, + artifactInfoCases, + emptyArtifactInfo, + artifactMetadataBinding, + artifactMetadataCases, + artifactKindBinding, + artifactKindCases, + artifactLocationBinding, + artifactLocationCases, + geometryCases, + emptyGeometry, +) where + +import Conformance.Structural.Domain qualified as Domain +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified as InfoShape +import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified as KindShape +import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified as LocationShape +import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified as MetadataShape +import Keiro.Codec.Structural (FixtureCases (..), StructuralBinding (..)) +import Keiro.Codec.Structural.Generic (genericStructuralBinding) + +artifactKindBinding :: StructuralBinding Domain.ArtifactKind KindShape.ArtifactKindShape +artifactKindBinding = genericStructuralBinding + +artifactLocationBinding :: StructuralBinding Domain.ArtifactLocation LocationShape.ArtifactLocationShape +artifactLocationBinding = genericStructuralBinding + +artifactMetadataBinding :: StructuralBinding Domain.ArtifactMetadata MetadataShape.ArtifactMetadataShape +artifactMetadataBinding = genericStructuralBinding + +artifactInfoBinding :: StructuralBinding Domain.ArtifactInfo InfoShape.ArtifactInfoShape +artifactInfoBinding = + StructuralBinding + { bindingToShape = \value -> + InfoShape.ArtifactInfo + value.artifactKey + value.displayName + value.artifactHash + (bindingToShape artifactKindBinding value.artifactKind) + (bindingToShape artifactLocationBinding value.location) + (bindingToShape artifactMetadataBinding value.metadata) + value.active + value.tags + , bindingFromShape = \(InfoShape.ArtifactInfo artifactKey displayName artifactHash artifactKind location metadata active tags) -> + Domain.ArtifactInfo + artifactKey + displayName + artifactHash + (bindingFromShape artifactKindBinding artifactKind) + (bindingFromShape artifactLocationBinding location) + (bindingFromShape artifactMetadataBinding metadata) + active + tags + } + +artifactKindCases :: FixtureCases Domain.ArtifactKind +artifactKindCases = FixtureCases (("guide", Domain.Guide) :| [("reference", Domain.Reference)]) + +artifactLocationCases :: FixtureCases Domain.ArtifactLocation +artifactLocationCases = + FixtureCases + ( ("local-file", Domain.LocalFile "/tmp/artifact.txt") + :| [ ("local-dir", Domain.LocalDir "/tmp/artifacts") + , ("repo-path", Domain.RepoPath "docs/artifact.md") + , ("url", Domain.LocUrl "https://example.test/artifact") + , ("canonical", Domain.Canonical) + ] + ) + +artifactMetadataCases :: FixtureCases Domain.ArtifactMetadata +artifactMetadataCases = + FixtureCases + ( ("without-note", Domain.ArtifactMetadata Nothing) + :| [("with-note", Domain.ArtifactMetadata (Just "consumer note"))] + ) + +artifactInfoCases :: FixtureCases Domain.ArtifactInfo +artifactInfoCases = + FixtureCases + ( ( "local-file-no-hash" + , artifact "artifact-local-file" "Local file" Nothing Domain.Guide (Domain.LocalFile "/tmp/artifact.txt") Nothing + ) + :| [ + ( "local-dir-with-hash" + , artifact "artifact-local-dir" "Local directory" (Just "sha256:01") Domain.Reference (Domain.LocalDir "/tmp/artifacts") (Just "directory") + ) + , + ( "repo-path" + , artifact "artifact-repo" "Repository path" Nothing Domain.Guide (Domain.RepoPath "docs/artifact.md") (Just "repository") + ) + , + ( "url" + , artifact "artifact-url" "URL" (Just "sha256:02") Domain.Reference (Domain.LocUrl "https://example.test/artifact") Nothing + ) + , + ( "canonical" + , artifact "artifact-canonical" "Canonical" Nothing Domain.Guide Domain.Canonical (Just "canonical") + ) + ] + ) + +artifact :: Text -> Text -> Maybe Text -> Domain.ArtifactKind -> Domain.ArtifactLocation -> Maybe Text -> Domain.ArtifactInfo +artifact artifactKey displayName artifactHash artifactKind location note = + Domain.ArtifactInfo + { Domain.artifactKey = artifactKey + , Domain.displayName = displayName + , Domain.artifactHash = artifactHash + , Domain.artifactKind = artifactKind + , Domain.location = location + , Domain.metadata = Domain.ArtifactMetadata note + , Domain.active = True + , Domain.tags = ["conformance", artifactKey] + } + +emptyArtifactInfo :: Domain.ArtifactInfo +emptyArtifactInfo = artifact "artifact-empty" "Empty" Nothing Domain.Guide Domain.Canonical Nothing + +geometryCases :: FixtureCases Domain.Geometry +geometryCases = + FixtureCases + ( ("point", Domain.Geometry "POINT (1 2)") + :| [("polygon", Domain.Geometry "POLYGON ((0 0, 1 0, 1 1, 0 0))")] + ) + +emptyGeometry :: Domain.Geometry +emptyGeometry = Domain.Geometry "GEOMETRYCOLLECTION EMPTY" diff --git a/test/conformance-structural/Conformance/Structural/Domain.hs b/test/conformance-structural/Conformance/Structural/Domain.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Conformance/Structural/Domain.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Conformance.Structural.Domain ( + ArtifactInfo (..), + ArtifactMetadata (..), + ArtifactKind (..), + ArtifactLocation (..), + Geometry (..), +) where + +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy (Proxy) +import Data.Text (Text) +import GHC.Generics (Generic) +import Keiki.Shape (CanonicalTypeName (..)) + +data ArtifactInfo = ArtifactInfo + { artifactKey :: !Text + , displayName :: !Text + , artifactHash :: !(Maybe Text) + , artifactKind :: !ArtifactKind + , location :: !ArtifactLocation + , metadata :: !ArtifactMetadata + , active :: !Bool + , tags :: ![Text] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, NFData, ToJSON) + +data ArtifactMetadata = ArtifactMetadata + { note :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, NFData, ToJSON) + +data ArtifactKind = Guide | Reference + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, NFData, ToJSON) + +data ArtifactLocation + = LocalFile !Text + | LocalDir !Text + | RepoPath !Text + | LocUrl !Text + | Canonical + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, NFData, ToJSON) + +newtype Geometry = Geometry {geometryWkt :: Text} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, NFData, ToJSON) + +instance CanonicalTypeName ArtifactInfo where + canonicalTypeName :: Proxy ArtifactInfo -> Text + canonicalTypeName _ = "conformance.structural.ArtifactInfo.v1" + +instance CanonicalTypeName ArtifactMetadata where + canonicalTypeName :: Proxy ArtifactMetadata -> Text + canonicalTypeName _ = "conformance.structural.ArtifactMetadata.v1" + +instance CanonicalTypeName ArtifactKind where + canonicalTypeName :: Proxy ArtifactKind -> Text + canonicalTypeName _ = "conformance.structural.ArtifactKind.v1" + +instance CanonicalTypeName ArtifactLocation where + canonicalTypeName :: Proxy ArtifactLocation -> Text + canonicalTypeName _ = "conformance.structural.ArtifactLocation.v1" diff --git a/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.ArtifactCatalog.Codec ( + artifactCatalogCodec, + parseArtifactCatalogEvent, + encodeArtifactCatalogEvent, + encodeArtifactInfoMapped, + decodeArtifactInfoMapped, + encodeArtifactKindMapped, + decodeArtifactKindMapped, + encodeArtifactLocationMapped, + decodeArtifactLocationMapped, + encodeArtifactMetadataMapped, + decodeArtifactMetadataMapped, +) where + +import Control.Monad (unless) +import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser, parseEither) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Generated.StructuralConformance.ArtifactCatalog.Domain +import Keiro.Codec (Codec (..), EventType (..)) +import Keiro.Codec.Structural (bindingFromShape, bindingToShape) + +import Conformance.Structural.Bindings qualified +import Conformance.Structural.Domain qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified + +encodeArtifactInfoMapped :: Conformance.Structural.Domain.ArtifactInfo -> Value +encodeArtifactInfoMapped = encodeArtifactInfoShape . bindingToShape Conformance.Structural.Bindings.artifactInfoBinding + +parseArtifactInfoMapped :: Value -> Parser Conformance.Structural.Domain.ArtifactInfo +parseArtifactInfoMapped value = bindingFromShape Conformance.Structural.Bindings.artifactInfoBinding <$> parseArtifactInfoShape value + +decodeArtifactInfoMapped :: Value -> Either Text Conformance.Structural.Domain.ArtifactInfo +decodeArtifactInfoMapped = mapLeftText . parseEither parseArtifactInfoMapped + +encodeArtifactInfoShape :: Generated.StructuralConformance.Structural.Shape.ArtifactInfo.ArtifactInfoShape -> Value +encodeArtifactInfoShape shape = + object + [ "artifact_key" .= toJSON (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactKey shape) + , "display_name" .= toJSON (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.displayName shape) + , "artifact_hash" .= maybe Null (\item -> toJSON (item)) (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactHash shape) + , "artifact_kind" .= encodeArtifactKindShape (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactKind shape) + , "location" .= encodeArtifactLocationShape (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.location shape) + , "metadata" .= encodeArtifactMetadataShape (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.metadata shape) + , "active" .= toJSON (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.active shape) + , "tags" .= toJSON (map (\item -> toJSON (item)) (Generated.StructuralConformance.Structural.Shape.ArtifactInfo.tags shape)) + ] + +parseArtifactInfoShape :: Value -> Parser Generated.StructuralConformance.Structural.Shape.ArtifactInfo.ArtifactInfoShape +parseArtifactInfoShape = withObject "ArtifactInfoShape" $ \objectValue -> do + rejectUnknownFields "ArtifactInfo" ["artifact_key", "display_name", "artifact_hash", "artifact_kind", "location", "metadata", "active", "tags"] objectValue + Generated.StructuralConformance.Structural.Shape.ArtifactInfo.ArtifactInfo + <$> ((objectValue .: "artifact_key" :: Parser Value) >>= (parseJSON)) + <*> ((objectValue .: "display_name" :: Parser Value) >>= (parseJSON)) + <*> (case KeyMap.lookup (Key.fromText "artifact_hash") objectValue of Nothing -> pure Nothing; Just presentValue -> (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) presentValue) + <*> (case KeyMap.lookup (Key.fromText "artifact_kind") objectValue of Nothing -> pure Generated.StructuralConformance.Structural.Shape.ArtifactKind.Guide; Just presentValue -> (parseArtifactKindShape) presentValue) + <*> ((objectValue .: "location" :: Parser Value) >>= (parseArtifactLocationShape)) + <*> ((objectValue .: "metadata" :: Parser Value) >>= (parseArtifactMetadataShape)) + <*> (case KeyMap.lookup (Key.fromText "active") objectValue of Nothing -> pure False; Just presentValue -> (parseJSON) presentValue) + <*> (case KeyMap.lookup (Key.fromText "tags") objectValue of Nothing -> pure []; Just presentValue -> (\value -> (parseJSON value :: Parser [Value]) >>= traverse (parseJSON)) presentValue) + +encodeArtifactKindMapped :: Conformance.Structural.Domain.ArtifactKind -> Value +encodeArtifactKindMapped = encodeArtifactKindShape . bindingToShape Conformance.Structural.Bindings.artifactKindBinding + +parseArtifactKindMapped :: Value -> Parser Conformance.Structural.Domain.ArtifactKind +parseArtifactKindMapped value = bindingFromShape Conformance.Structural.Bindings.artifactKindBinding <$> parseArtifactKindShape value + +decodeArtifactKindMapped :: Value -> Either Text Conformance.Structural.Domain.ArtifactKind +decodeArtifactKindMapped = mapLeftText . parseEither parseArtifactKindMapped + +encodeArtifactKindShape :: Generated.StructuralConformance.Structural.Shape.ArtifactKind.ArtifactKindShape -> Value +encodeArtifactKindShape = \case + Generated.StructuralConformance.Structural.Shape.ArtifactKind.Guide -> String "guide" + Generated.StructuralConformance.Structural.Shape.ArtifactKind.Reference -> String "reference" + +parseArtifactKindShape :: Value -> Parser Generated.StructuralConformance.Structural.Shape.ArtifactKind.ArtifactKindShape +parseArtifactKindShape = withText "ArtifactKindShape" $ \tag -> case tag of + "guide" -> pure Generated.StructuralConformance.Structural.Shape.ArtifactKind.Guide + "reference" -> pure Generated.StructuralConformance.Structural.Shape.ArtifactKind.Reference + _ -> fail "unknown ArtifactKind wire value" + +encodeArtifactLocationMapped :: Conformance.Structural.Domain.ArtifactLocation -> Value +encodeArtifactLocationMapped = encodeArtifactLocationShape . bindingToShape Conformance.Structural.Bindings.artifactLocationBinding + +parseArtifactLocationMapped :: Value -> Parser Conformance.Structural.Domain.ArtifactLocation +parseArtifactLocationMapped value = bindingFromShape Conformance.Structural.Bindings.artifactLocationBinding <$> parseArtifactLocationShape value + +decodeArtifactLocationMapped :: Value -> Either Text Conformance.Structural.Domain.ArtifactLocation +decodeArtifactLocationMapped = mapLeftText . parseEither parseArtifactLocationMapped + +encodeArtifactLocationShape :: Generated.StructuralConformance.Structural.Shape.ArtifactLocation.ArtifactLocationShape -> Value +encodeArtifactLocationShape = \case + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalFile payload -> + object + [ "tag" .= ("local_file" :: Text) + , "contents" .= toJSON (payload) + ] + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalDir payload -> + object + [ "tag" .= ("local_dir" :: Text) + , "contents" .= toJSON (payload) + ] + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.RepoPath payload -> + object + [ "tag" .= ("repo_path" :: Text) + , "contents" .= toJSON (payload) + ] + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocUrl payload -> + object + [ "tag" .= ("url" :: Text) + , "contents" .= toJSON (payload) + ] + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.Canonical -> + object + [ "tag" .= ("canonical" :: Text) + ] + +parseArtifactLocationShape :: Value -> Parser Generated.StructuralConformance.Structural.Shape.ArtifactLocation.ArtifactLocationShape +parseArtifactLocationShape = withObject "ArtifactLocationShape" $ \objectValue -> do + tag <- objectValue .: "tag" :: Parser Text + case tag of + "local_file" -> do + rejectUnknownFields "ArtifactLocation" ["tag", "contents"] objectValue + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalFile <$> (objectValue .: "contents" >>= (parseJSON)) + "local_dir" -> do + rejectUnknownFields "ArtifactLocation" ["tag", "contents"] objectValue + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalDir <$> (objectValue .: "contents" >>= (parseJSON)) + "repo_path" -> do + rejectUnknownFields "ArtifactLocation" ["tag", "contents"] objectValue + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.RepoPath <$> (objectValue .: "contents" >>= (parseJSON)) + "url" -> do + rejectUnknownFields "ArtifactLocation" ["tag", "contents"] objectValue + Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocUrl <$> (objectValue .: "contents" >>= (parseJSON)) + "canonical" -> do + rejectUnknownFields "ArtifactLocation" ["tag"] objectValue + pure Generated.StructuralConformance.Structural.Shape.ArtifactLocation.Canonical + _ -> fail "unknown ArtifactLocation union tag" + +encodeArtifactMetadataMapped :: Conformance.Structural.Domain.ArtifactMetadata -> Value +encodeArtifactMetadataMapped = encodeArtifactMetadataShape . bindingToShape Conformance.Structural.Bindings.artifactMetadataBinding + +parseArtifactMetadataMapped :: Value -> Parser Conformance.Structural.Domain.ArtifactMetadata +parseArtifactMetadataMapped value = bindingFromShape Conformance.Structural.Bindings.artifactMetadataBinding <$> parseArtifactMetadataShape value + +decodeArtifactMetadataMapped :: Value -> Either Text Conformance.Structural.Domain.ArtifactMetadata +decodeArtifactMetadataMapped = mapLeftText . parseEither parseArtifactMetadataMapped + +encodeArtifactMetadataShape :: Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.ArtifactMetadataShape -> Value +encodeArtifactMetadataShape shape = + object + [ "note" .= maybe Null (\item -> toJSON (item)) (Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.note shape) + ] + +parseArtifactMetadataShape :: Value -> Parser Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.ArtifactMetadataShape +parseArtifactMetadataShape = withObject "ArtifactMetadataShape" $ \objectValue -> do + Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.ArtifactMetadata + <$> ((objectValue .: "note" :: Parser Value) >>= (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other)) + +artifactCatalogCodec :: Codec ArtifactCatalogEvent +artifactCatalogCodec = + Codec + { eventTypes = EventType "ArtifactRecorded" :| [EventType "ArtifactAccepted"] + , eventType = \case + ArtifactRecorded{} -> EventType "ArtifactRecorded" + ArtifactAccepted{} -> EventType "ArtifactAccepted" + , schemaVersion = 1 + , encode = encodeArtifactCatalogEvent + , decode = parseArtifactCatalogEvent + , upcasters = [] + } + +encodeArtifactCatalogEvent :: ArtifactCatalogEvent -> Value +encodeArtifactCatalogEvent = \case + ArtifactRecorded payload -> + object + [ "kind" .= ("ArtifactRecorded" :: Text) + , "artifact" .= encodeArtifactInfoMapped payload.artifact + , "geometry" .= toJSON payload.geometry + , "accepted" .= payload.accepted + ] + ArtifactAccepted payload -> + object + [ "kind" .= ("ArtifactAccepted" :: Text) + , "accepted" .= payload.accepted + ] + +parseArtifactCatalogEvent :: EventType -> Value -> Either Text ArtifactCatalogEvent +parseArtifactCatalogEvent (EventType tag) = mapLeftText . parseEither (withObject "ArtifactCatalogEvent" go) + where + go o = do + case tag of + "ArtifactRecorded" -> + ArtifactRecorded <$> (ArtifactRecordedData <$> (o .: "artifact" >>= parseArtifactInfoMapped) <*> o .: "geometry" <*> o .: "accepted") + "ArtifactAccepted" -> + ArtifactAccepted <$> (ArtifactAcceptedData <$> o .: "accepted") + _ -> fail "unknown event type" + +mapLeftText :: Either String b -> Either Text b +mapLeftText = either (Left . T.pack) Right + +rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser () +rejectUnknownFields label allowed objectValue = + unless (null extras) (fail (label <> " contains unknown fields: " <> show extras)) + where + extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue)) diff --git a/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.ArtifactCatalog.Domain where + +import Conformance.Structural.Bindings qualified +import Conformance.Structural.Domain qualified +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Keiki.Core (RegFile (..)) +import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll) + +data ArtifactCatalogVertex = ArtifactCatalogEmpty | ArtifactCatalogObserved + deriving stock (Generic, Eq, Ord, Show, Enum, Bounded) + +data ObserveArtifactData = ObserveArtifactData + { artifact :: !Conformance.Structural.Domain.ArtifactInfo + , geometry :: !Conformance.Structural.Domain.Geometry + , accepted :: !Bool + } + deriving stock (Generic, Eq, Show) + +data ArtifactCatalogCommand = ObserveArtifact !ObserveArtifactData + deriving stock (Generic, Eq, Show) + +data ArtifactRecordedData = ArtifactRecordedData + { artifact :: !Conformance.Structural.Domain.ArtifactInfo + , geometry :: !Conformance.Structural.Domain.Geometry + , accepted :: !Bool + } + deriving stock (Generic, Eq, Show) + +data ArtifactAcceptedData = ArtifactAcceptedData + { accepted :: !Bool + } + deriving stock (Generic, Eq, Show) + +data ArtifactCatalogEvent + = ArtifactRecorded !ArtifactRecordedData + | ArtifactAccepted !ArtifactAcceptedData + deriving stock (Generic, Eq, Show) + +type ArtifactCatalogRegs = + '[ '("currentArtifact", Conformance.Structural.Domain.ArtifactInfo) + , '("currentGeometry", Conformance.Structural.Domain.Geometry) + , '("acceptedCount", Int) + ] + +initialArtifactCatalogRegs :: RegFile ArtifactCatalogRegs +initialArtifactCatalogRegs = + RCons (Proxy @"currentArtifact") Conformance.Structural.Bindings.emptyArtifactInfo $ + RCons (Proxy @"currentGeometry") Conformance.Structural.Bindings.emptyGeometry $ + RCons (Proxy @"acceptedCount") 0 RNil + +$(deriveAggregateCtorsAll ''ArtifactCatalogCommand ''ArtifactCatalogRegs) + +$(deriveWireCtorsAll ''ArtifactCatalogEvent) diff --git a/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs @@ -0,0 +1,44 @@ +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.ArtifactCatalog.EventStream ( + artifactCatalogCategory, + artifactCatalogEventStream, + artifactCatalogEventStreamDef, + ArtifactCatalogEventStream, + ArtifactCatalogEventStreamDef, +) where + +import Generated.StructuralConformance.ArtifactCatalog.Codec (artifactCatalogCodec) +import Generated.StructuralConformance.ArtifactCatalog.Domain +import Keiki.Core (HsPred) +import Keiro.EventStream (EventStream (..), SnapshotPolicy (..)) +import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow) +import Keiro.Stream qualified as Stream +import StructuralConformance.ArtifactCatalog.Holes (artifactCatalogTransducer) + +-- The validated aggregate stream category (hole-kind 5: referenced, never retyped). +-- Entity streams are '-' via Keiro.Stream.entityStream. +-- categoryUnsafe is safe here because this generated literal passed the DSL category proof. +artifactCatalogCategory :: Stream.StreamCategory a +artifactCatalogCategory = Stream.categoryUnsafe "artifactCatalog" + +type ArtifactCatalogEventStreamDef = + EventStream (HsPred ArtifactCatalogRegs ArtifactCatalogCommand) ArtifactCatalogRegs ArtifactCatalogVertex ArtifactCatalogCommand ArtifactCatalogEvent + +type ArtifactCatalogEventStream = + ValidatedEventStream (HsPred ArtifactCatalogRegs ArtifactCatalogCommand) ArtifactCatalogRegs ArtifactCatalogVertex ArtifactCatalogCommand ArtifactCatalogEvent + +artifactCatalogEventStreamDef :: ArtifactCatalogEventStreamDef +artifactCatalogEventStreamDef = + EventStream + { transducer = artifactCatalogTransducer + , initialState = ArtifactCatalogEmpty + , initialRegisters = initialArtifactCatalogRegs + , eventCodec = artifactCatalogCodec + , resolveStreamName = Stream.streamName + , snapshotPolicy = Never + , stateCodec = Nothing + } + +artifactCatalogEventStream :: ArtifactCatalogEventStream +artifactCatalogEventStream = + mkEventStreamOrThrow "ArtifactCatalog" artifactCatalogEventStreamDef diff --git a/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.ArtifactCatalog.Harness (harnessAssertions) where + +import Conformance.Structural.Bindings qualified +import Conformance.Structural.Domain qualified +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as AesonKey +import Data.Aeson.KeyMap qualified as AesonKeyMap +import Data.Either (isLeft, isRight) +import Data.List (nub) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (isJust, isNothing) +import Data.Proxy (Proxy (..)) +import Data.Text qualified as T +import Generated.StructuralConformance.ArtifactCatalog.Codec (artifactCatalogCodec, decodeArtifactInfoMapped, decodeArtifactKindMapped, decodeArtifactLocationMapped, decodeArtifactMetadataMapped, encodeArtifactCatalogEvent, encodeArtifactInfoMapped, encodeArtifactKindMapped, encodeArtifactLocationMapped, encodeArtifactMetadataMapped, parseArtifactCatalogEvent) +import Generated.StructuralConformance.ArtifactCatalog.Domain +import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified +import Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections +import Keiki.Core (applyEventsEither, defaultValidationOptions, fieldWitnessAgrees, step, validateTransducer, (!)) +import Keiki.Shape (CanonicalTypeName (..)) +import Keiro.Codec (eventType) +import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape) +import StructuralConformance.ArtifactCatalog.Holes (artifactCatalogTransducer) + +{- | (label, passed). A driver runs these and exits non-zero on any False, +naming the failing assertion. Filling a hole wrongly turns a specific +entry False; the scaffold cannot. +-} +harnessAssertions :: [(String, Bool)] +harnessAssertions = + [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions artifactCatalogTransducer)) + , ("clock-free: spec samples no wall clock", True) + , ("golden round-trip: ArtifactRecorded", roundTrips sampleEventArtifactRecorded) + , ("golden round-trip: ArtifactAccepted", roundTrips sampleEventArtifactAccepted) + , ("accepts ObserveArtifact from ArtifactCatalogEmpty", acceptObserveArtifact) + ] + ++ mappedConformanceAssertions + ++ forwardReplayObserveArtifact + +roundTrips :: ArtifactCatalogEvent -> Bool +roundTrips e = parseArtifactCatalogEvent (eventType artifactCatalogCodec e) (encodeArtifactCatalogEvent e) == Right e + +sampleEventArtifactRecorded :: ArtifactCatalogEvent +sampleEventArtifactRecorded = (ArtifactRecorded (ArtifactRecordedData (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.geometryCases))) False)) + +sampleEventArtifactAccepted :: ArtifactCatalogEvent +sampleEventArtifactAccepted = (ArtifactAccepted (ArtifactAcceptedData False)) + +acceptObserveArtifact :: Bool +acceptObserveArtifact = + case step artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) ((ObserveArtifact (ObserveArtifactData (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.geometryCases))) False))) of + Just (v, _, _) -> v == ArtifactCatalogObserved + Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayObserveArtifact :: [(String, Bool)] +forwardReplayObserveArtifact = + case step artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) ((ObserveArtifact (ObserveArtifactData (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.geometryCases))) False))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseArtifactCatalogEvent (eventType artifactCatalogCodec event) (encodeArtifactCatalogEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither artifactCatalogTransducer (ArtifactCatalogEmpty, initialArtifactCatalogRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register currentArtifact", (replayRegs ! #currentArtifact) == (forwardRegs ! #currentArtifact)) + , (prefix <> "register currentGeometry", (replayRegs ! #currentGeometry) == (forwardRegs ! #currentGeometry)) + , (prefix <> "register acceptedCount", (replayRegs ! #acceptedCount) == (forwardRegs ! #acceptedCount)) + ] + where + prefix = "forward/replay equality: ObserveArtifact from ArtifactCatalogEmpty -- " + +mappedConformanceAssertions :: [(String, Bool)] +mappedConformanceAssertions = + concat + [ artifactInfoBindingAssertions + , artifactKindBindingAssertions + , artifactLocationBindingAssertions + , artifactMetadataBindingAssertions + , vendorGeometryOpaqueAssertions + , [("fixture coverage: conformance.structural.ArtifactInfo.v1", coverageArtifactInfo)] + , [("fixture coverage: conformance.structural.ArtifactKind.v1", coverageArtifactKind)] + , [("fixture coverage: conformance.structural.ArtifactLocation.v1", coverageArtifactLocation)] + , [("fixture coverage: conformance.structural.ArtifactMetadata.v1", coverageArtifactMetadata)] + , artifactRecordedArtifactAssertions + , artifactRecordedGeometryAssertions + , structuralWirePolicyAssertions + , structuralProjectionAssertions + ] + +validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool +validFixtureLabels cases = + all (not . T.null) labels && length labels == length (nub labels) + where + labels = map fst (NonEmpty.toList cases) + +artifactInfoBindingAssertions :: [(String, Bool)] +artifactInfoBindingAssertions = + ("fixture labels: conformance.structural.ArtifactInfo.v1", validFixtureLabels cases) + : ("canonical identity: conformance.structural.ArtifactInfo.v1", canonicalTypeName (Proxy @Conformance.Structural.Domain.ArtifactInfo) == "conformance.structural.ArtifactInfo.v1") + : concat + [ [ ("binding domain round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingDomainRoundTrip Conformance.Structural.Bindings.artifactInfoBinding value) + , ("binding shape round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingShapeRoundTrip Conformance.Structural.Bindings.artifactInfoBinding (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding value)) + ] + | (label, value) <- NonEmpty.toList cases + ] + where + cases = fixtureCases Conformance.Structural.Bindings.artifactInfoCases + +artifactKindBindingAssertions :: [(String, Bool)] +artifactKindBindingAssertions = + ("fixture labels: conformance.structural.ArtifactKind.v1", validFixtureLabels cases) + : ("canonical identity: conformance.structural.ArtifactKind.v1", canonicalTypeName (Proxy @Conformance.Structural.Domain.ArtifactKind) == "conformance.structural.ArtifactKind.v1") + : concat + [ [ ("binding domain round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingDomainRoundTrip Conformance.Structural.Bindings.artifactKindBinding value) + , ("binding shape round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingShapeRoundTrip Conformance.Structural.Bindings.artifactKindBinding (bindingToShape Conformance.Structural.Bindings.artifactKindBinding value)) + ] + | (label, value) <- NonEmpty.toList cases + ] + where + cases = fixtureCases Conformance.Structural.Bindings.artifactKindCases + +artifactLocationBindingAssertions :: [(String, Bool)] +artifactLocationBindingAssertions = + ("fixture labels: conformance.structural.ArtifactLocation.v1", validFixtureLabels cases) + : ("canonical identity: conformance.structural.ArtifactLocation.v1", canonicalTypeName (Proxy @Conformance.Structural.Domain.ArtifactLocation) == "conformance.structural.ArtifactLocation.v1") + : concat + [ [ ("binding domain round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingDomainRoundTrip Conformance.Structural.Bindings.artifactLocationBinding value) + , ("binding shape round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingShapeRoundTrip Conformance.Structural.Bindings.artifactLocationBinding (bindingToShape Conformance.Structural.Bindings.artifactLocationBinding value)) + ] + | (label, value) <- NonEmpty.toList cases + ] + where + cases = fixtureCases Conformance.Structural.Bindings.artifactLocationCases + +artifactMetadataBindingAssertions :: [(String, Bool)] +artifactMetadataBindingAssertions = + ("fixture labels: conformance.structural.ArtifactMetadata.v1", validFixtureLabels cases) + : ("canonical identity: conformance.structural.ArtifactMetadata.v1", canonicalTypeName (Proxy @Conformance.Structural.Domain.ArtifactMetadata) == "conformance.structural.ArtifactMetadata.v1") + : concat + [ [ ("binding domain round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingDomainRoundTrip Conformance.Structural.Bindings.artifactMetadataBinding value) + , ("binding shape round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingShapeRoundTrip Conformance.Structural.Bindings.artifactMetadataBinding (bindingToShape Conformance.Structural.Bindings.artifactMetadataBinding value)) + ] + | (label, value) <- NonEmpty.toList cases + ] + where + cases = fixtureCases Conformance.Structural.Bindings.artifactMetadataCases + +vendorGeometryOpaqueAssertions :: [(String, Bool)] +vendorGeometryOpaqueAssertions = + ("opaque boundary fixtures: vendor.geometry.json@3", validFixtureLabels cases) + : [ ("opaque codec round-trip: vendor.geometry.json@3/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False) + | (caseLabel, value) <- NonEmpty.toList cases + ] + where + cases = fixtureCases Conformance.Structural.Bindings.geometryCases + +coverageArtifactInfo :: Bool +coverageArtifactInfo = any (isNothing . Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactHash) shapes && any (isJust . Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactHash) shapes + where + shapes = map (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding . snd) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactInfoCases)) + +coverageArtifactKind :: Bool +coverageArtifactKind = any (\case Generated.StructuralConformance.Structural.Shape.ArtifactKind.Guide -> True; _ -> False) shapes && any (\case Generated.StructuralConformance.Structural.Shape.ArtifactKind.Reference -> True; _ -> False) shapes + where + shapes = map (bindingToShape Conformance.Structural.Bindings.artifactKindBinding . snd) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactKindCases)) + +coverageArtifactLocation :: Bool +coverageArtifactLocation = any (\case Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalFile{} -> True; _ -> False) shapes && any (\case Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocalDir{} -> True; _ -> False) shapes && any (\case Generated.StructuralConformance.Structural.Shape.ArtifactLocation.RepoPath{} -> True; _ -> False) shapes && any (\case Generated.StructuralConformance.Structural.Shape.ArtifactLocation.LocUrl{} -> True; _ -> False) shapes && any (\case Generated.StructuralConformance.Structural.Shape.ArtifactLocation.Canonical -> True; _ -> False) shapes + where + shapes = map (bindingToShape Conformance.Structural.Bindings.artifactLocationBinding . snd) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases)) + +coverageArtifactMetadata :: Bool +coverageArtifactMetadata = any (isNothing . Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.note) shapes && any (isJust . Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.note) shapes + where + shapes = map (bindingToShape Conformance.Structural.Bindings.artifactMetadataBinding . snd) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactMetadataCases)) + +artifactRecordedArtifactAssertions :: [(String, Bool)] +artifactRecordedArtifactAssertions = + [ ("mapped codec round-trip: ArtifactRecorded/artifact/" <> T.unpack label, roundTrips (ArtifactRecorded (ArtifactRecordedData mappedValue (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.geometryCases))) False))) + | (label, mappedValue) <- NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactInfoCases) + ] + +artifactRecordedGeometryAssertions :: [(String, Bool)] +artifactRecordedGeometryAssertions = + [ ("mapped codec round-trip: ArtifactRecorded/geometry/" <> T.unpack label, roundTrips (ArtifactRecorded (ArtifactRecordedData (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) mappedValue False))) + | (label, mappedValue) <- NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.geometryCases) + ] + +structuralWirePolicyAssertions :: [(String, Bool)] +structuralWirePolicyAssertions = + [ ("wire policy missing default: conformance.structural.ArtifactInfo.v1/artifact_hash", case decodeArtifactInfoMapped (deleteObjectField "artifact_hash" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "artifact_hash" (encodeArtifactInfoMapped decoded) == Just (Aeson.Null)) + , ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/artifact_hash", isRight (decodeArtifactInfoMapped (insertObjectField "artifact_hash" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))))) + , ("wire policy missing default: conformance.structural.ArtifactInfo.v1/artifact_kind", case decodeArtifactInfoMapped (deleteObjectField "artifact_kind" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "artifact_kind" (encodeArtifactInfoMapped decoded) == Just (Aeson.String "guide")) + , ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/artifact_kind", isLeft (decodeArtifactInfoMapped (insertObjectField "artifact_kind" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))))) + , ("wire policy missing default: conformance.structural.ArtifactInfo.v1/active", case decodeArtifactInfoMapped (deleteObjectField "active" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "active" (encodeArtifactInfoMapped decoded) == Just (Aeson.Bool False)) + , ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/active", isLeft (decodeArtifactInfoMapped (insertObjectField "active" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))))) + , ("wire policy missing default: conformance.structural.ArtifactInfo.v1/tags", case decodeArtifactInfoMapped (deleteObjectField "tags" (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))) of Left _ -> False; Right decoded -> objectField "tags" (encodeArtifactInfoMapped decoded) == Just (Aeson.toJSON ([] :: [Aeson.Value]))) + , ("wire policy explicit null: conformance.structural.ArtifactInfo.v1/tags", isLeft (decodeArtifactInfoMapped (insertObjectField "tags" Aeson.Null (encodeArtifactInfoMapped (snd (NonEmpty.head (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))))))) + , ("wire policy unknown fields: conformance.structural.ArtifactInfo.v1", all (\(_, value) -> isLeft (decodeArtifactInfoMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactInfoMapped value)))) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) + , ("wire enum arm: conformance.structural.ArtifactKind.v1/guide", any (\(_, value) -> encodeArtifactKindMapped value == Aeson.String "guide" && decodeArtifactKindMapped (Aeson.String "guide") == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactKindCases))) + , ("wire enum arm: conformance.structural.ArtifactKind.v1/reference", any (\(_, value) -> encodeArtifactKindMapped value == Aeson.String "reference" && decodeArtifactKindMapped (Aeson.String "reference") == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactKindCases))) + , ("wire enum unknown tag: conformance.structural.ArtifactKind.v1", isLeft (decodeArtifactKindMapped (Aeson.String "__keiro_unknown"))) + , ("wire union arm: conformance.structural.ArtifactLocation.v1/local_file", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "local_file") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire union arm: conformance.structural.ArtifactLocation.v1/local_dir", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "local_dir") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire union arm: conformance.structural.ArtifactLocation.v1/repo_path", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "repo_path") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire union arm: conformance.structural.ArtifactLocation.v1/url", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "url") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire union arm: conformance.structural.ArtifactLocation.v1/canonical", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "canonical") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire policy unknown fields: conformance.structural.ArtifactLocation.v1", all (\(_, value) -> isLeft (decodeArtifactLocationMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactLocationMapped value)))) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactLocationCases))) + , ("wire policy unknown fields: conformance.structural.ArtifactMetadata.v1", all (\(_, value) -> isRight (decodeArtifactMetadataMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactMetadataMapped value)))) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactMetadataCases))) + ] + +structuralProjectionAssertions :: [(String, Bool)] +structuralProjectionAssertions = + [ ("projection witness agreement: conformance.structural.ArtifactInfo.v1/artifact_key", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness (\referenceOwner -> Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactKey (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) + , ("projection witness agreement: conformance.structural.ArtifactInfo.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65ZWitness (\referenceOwner -> Generated.StructuralConformance.Structural.Shape.ArtifactInfo.displayName (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Conformance.Structural.Bindings.artifactInfoCases))) + ] + +deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value +deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue) +deleteObjectField _ value = value + +insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value +insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue) +insertObjectField _ _ value = value + +objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value +objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue +objectField _ _ = Nothing diff --git a/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs @@ -0,0 +1,2 @@ +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.ArtifactCatalog.Projection () where diff --git a/test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs b/test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.StructuralConformance.ReplayAudit (auditTargets) where + +import Generated.StructuralConformance.ArtifactCatalog.EventStream qualified as ArtifactCatalog +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = ArtifactCatalog.artifactCatalogEventStream + , category = Stream.categoryText ArtifactCatalog.artifactCatalogCategory + , mkStream = streamInCategory (Stream.categoryText ArtifactCatalog.artifactCatalogCategory) + } + ] diff --git a/test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs b/test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit. +-- This module compares historical and generated codecs in consumer-owned tests only. +-- It is never a runtime fallback and never changes the generated codec's authority. +module Generated.StructuralConformance.Structural.CodecCompare.ArtifactInfo (compareWithHistorical) where + +import Control.Monad (filterM) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.List (sort) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text (Text) +import Data.Text qualified +import Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec +import Keiro.Codec.Structural (FixtureCases (..)) +import Keiro.Dsl.CodecCompare +import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..)) +import System.Directory (doesFileExist, listDirectory) +import System.FilePath (takeExtension, ()) + +import Conformance.Structural.Bindings qualified as ConsumerFixtures +import Conformance.Structural.Domain qualified as ConsumerDomain + +compareWithHistorical :: HistoricalCodec ConsumerDomain.ArtifactInfo -> FilePath -> IO CompareReport +compareWithHistorical historicalCodec goldenDirectory = do + names <- sort . filter ((== ".json") . takeExtension) <$> listDirectory goldenDirectory + files <- filterM doesFileExist [goldenDirectory name | name <- names] + loaded <- traverse (loadGolden historicalCodec) files + let inputIssues = [issue | Left issue <- loaded] + entries = [entry | Right entry <- loaded] + typedCases = NonEmpty.toList (fixtureCases ConsumerFixtures.artifactInfoCases) + encodeObservations = + [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encodeArtifactInfoMapped value) + | (label, value) <- typedCases + ] + decodeObservations = [observation | (observation, _) <- entries] + typedObserved = + concat + [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encodeArtifactInfoMapped value) + | (_, value) <- typedCases + ] + historicalObserved = + concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values] + declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema + provenance = + CompareProvenance + { cpHistoricalCodecIdentity = hcIdentity historicalCodec + , cpHistoricalCodecVersion = hcVersion historicalCodec + , cpCanonicalType = CanonicalTypeId "conformance.structural.ArtifactInfo.v1" + , cpBindingSymbol = QualifiedValueName "Conformance.Structural.Bindings.artifactInfoBinding" + , cpBindingVersion = BindingVersion "1" + , cpWireFingerprint = "f3b9417666fcf445" + } + pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved)) + +loadGolden :: HistoricalCodec ConsumerDomain.ArtifactInfo -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value])) +loadGolden historicalCodec path = do + decoded <- Aeson.eitherDecodeFileStrict path + pure $ case decoded of + Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason)) + Right inputValue -> + let historicalDecoded = hcDecode historicalCodec inputValue + historicalOutcome = normalizeDecode historicalDecoded + generatedOutcome = normalizeDecode (GeneratedCodec.decodeArtifactInfoMapped inputValue) + observation = DecodeObservation path inputValue historicalOutcome generatedOutcome + coveredValues = case historicalDecoded of + Right value -> [inputValue, GeneratedCodec.encodeArtifactInfoMapped value] + Left _ -> [] + in Right (observation, coveredValues) + +normalizeDecode :: Either Text ConsumerDomain.ArtifactInfo -> DecodeOutcome +normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encodeArtifactInfoMapped) + +fromString :: String -> Text +fromString = Data.Text.pack + +branchSchema :: BranchSchema +branchSchema = BranchRecord [BranchField "artifact_key" False (BranchScalar), BranchField "display_name" False (BranchScalar), BranchField "artifact_hash" True (BranchOptional (BranchScalar)), BranchField "artifact_kind" True (BranchScalar), BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local_file" (Just (BranchScalar)), BranchArm "local_dir" (Just (BranchScalar)), BranchArm "repo_path" (Just (BranchScalar)), BranchArm "url" (Just (BranchScalar)), BranchArm "canonical" Nothing]), BranchField "metadata" False (BranchRecord [BranchField "note" False (BranchOptional (BranchScalar))]), BranchField "active" True (BranchScalar), BranchField "tags" True (BranchList (BranchScalar))] diff --git a/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.Structural.Shape.ArtifactInfo (ArtifactInfoShape (..)) where + +import Data.Text (Text) +import GHC.Generics (Generic) +import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified +import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified + +data ArtifactInfoShape = ArtifactInfo + { artifactKey :: !Text + , displayName :: !Text + , artifactHash :: !(Maybe (Text)) + , artifactKind :: !Generated.StructuralConformance.Structural.Shape.ArtifactKind.ArtifactKindShape + , location :: !Generated.StructuralConformance.Structural.Shape.ArtifactLocation.ArtifactLocationShape + , metadata :: !Generated.StructuralConformance.Structural.Shape.ArtifactMetadata.ArtifactMetadataShape + , active :: !Bool + , tags :: !([Text]) + } + deriving stock (Eq, Generic, Show) diff --git a/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.Structural.Shape.ArtifactKind (ArtifactKindShape (..)) where + +import GHC.Generics (Generic) + +data ArtifactKindShape = Guide | Reference + deriving stock (Eq, Generic, Show) diff --git a/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.Structural.Shape.ArtifactLocation (ArtifactLocationShape (..)) where + +import Data.Text (Text) +import GHC.Generics (Generic) + +data ArtifactLocationShape + = LocalFile !Text + | LocalDir !Text + | RepoPath !Text + | LocUrl !Text + | Canonical + deriving stock (Eq, Generic, Show) diff --git a/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +module Generated.StructuralConformance.Structural.Shape.ArtifactMetadata (ArtifactMetadataShape (..)) where + +import Data.Text (Text) +import GHC.Generics (Generic) + +data ArtifactMetadataShape = ArtifactMetadata + { note :: !(Maybe (Text)) + } + deriving stock (Eq, Generic, Show) diff --git a/test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs b/test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- Equality witnesses are emitted for Text, Int, Bool, and UTCTime. +-- Only Int and UTCTime belong to Keiki's v1 ordered subset. +module Generated.StructuralConformance.StructuralProjections ( + structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness, + structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65ZWitness, +) where + +import Conformance.Structural.Bindings qualified +import Conformance.Structural.Domain qualified +import Data.Text (Text) +import Data.Time (UTCTime) +import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified +import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness) +import Keiro.Codec.Structural (bindingToShape) + +data StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z + +instance FieldProjection StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z where + type FieldName StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z = "/artifact_key" + type FieldOwner StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z = Conformance.Structural.Domain.ArtifactInfo + type FieldResult StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z = Text + fieldShapeId _ = "conformance.structural.ArtifactInfo.v1" + projectFieldValue _ owner = Generated.StructuralConformance.Structural.Shape.ArtifactInfo.artifactKey (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding owner) + +structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness :: FieldWitness StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z +structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness = fieldWitness @StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79Z + +data StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z + +instance FieldProjection StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z where + type FieldName StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z = "/display_name" + type FieldOwner StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z = Conformance.Structural.Domain.ArtifactInfo + type FieldResult StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z = Text + fieldShapeId _ = "conformance.structural.ArtifactInfo.v1" + projectFieldValue _ owner = Generated.StructuralConformance.Structural.Shape.ArtifactInfo.displayName (bindingToShape Conformance.Structural.Bindings.artifactInfoBinding owner) + +structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65ZWitness :: FieldWitness StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z +structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65ZWitness = fieldWitness @StructuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC64ZC69ZC73ZC70ZC6cZC61ZC79ZC5fZC6eZC61ZC6dZC65Z diff --git a/test/conformance-structural/Main.hs b/test/conformance-structural/Main.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/Main.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} + +module Main (main) where + +import Conformance.Structural.Bindings qualified as Bindings +import Control.Monad (forM_, unless) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LazyByteString +import Data.ByteString.Lazy.Char8 qualified as LazyChar8 +import Data.List.NonEmpty qualified as NonEmpty +import Generated.StructuralConformance.ArtifactCatalog.Codec (encodeArtifactCatalogEvent) +import Generated.StructuralConformance.ArtifactCatalog.Domain (ArtifactCatalogCommand, ArtifactCatalogEvent (..), ArtifactCatalogRegs, ArtifactRecordedData (..), inCtorObserveArtifact) +import Generated.StructuralConformance.ArtifactCatalog.Harness (harnessAssertions) +import Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections +import Keiki.Core (HsPred, inpProj, (./=)) +import Keiki.Symbolic (symIsBot) +import Keiro.Codec.Structural (FixtureCases (..)) +import System.Exit (exitFailure) + +main :: IO () +main = do + goldenAssertions <- loadGoldenAssertions + let assertions = harnessAssertions <> projectionAssertions <> goldenAssertions + forM_ assertions $ \(label, ok) -> + putStrLn ((if ok then "PASS " else "FAIL ") <> label) + let failed = [label | (label, ok) <- assertions, not ok] + unless (null failed) $ do + putStrLn ("structural harness: " <> show (length failed) <> " assertion(s) failed") + exitFailure + +projectionAssertions :: [(String, Bool)] +projectionAssertions = + [ + ( "projection key sharing: conformance.structural.ArtifactInfo.v1/artifact_key" + , symIsBot + ( inpProj artifactKeyWitness inCtorObserveArtifact #artifact + ./= inpProj artifactKeyWitness inCtorObserveArtifact #artifact :: + HsPred ArtifactCatalogRegs ArtifactCatalogCommand + ) + ) + ] + where + artifactKeyWitness = StructuralProjections.structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness + +loadGoldenAssertions :: IO [(String, Bool)] +loadGoldenAssertions = do + actual <- LazyByteString.readFile "test/golden-payloads/structural-conformance/ArtifactCatalog/ArtifactRecorded.v1.json" + let artifact = snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases)) + geometry = snd (NonEmpty.head (fixtureCases Bindings.geometryCases)) + event = ArtifactRecorded ArtifactRecordedData{artifact, geometry, accepted = False} + expected = Aeson.encode (encodeArtifactCatalogEvent event) <> "\n" + unless (actual == expected) $ do + LazyChar8.putStrLn ("expected: " <> expected) + LazyChar8.putStrLn ("actual: " <> actual) + pure [("current JSON golden: ArtifactRecorded.v1", actual == expected)] diff --git a/test/conformance-structural/StructuralConformance/ArtifactCatalog/Holes.hs b/test/conformance-structural/StructuralConformance/ArtifactCatalog/Holes.hs new file mode 100644 --- /dev/null +++ b/test/conformance-structural/StructuralConformance/ArtifactCatalog/Holes.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE TypeApplications #-} + +-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never +-- overwrites it. Fill the transducer body (and any other holes) against the +-- generated signatures, then run the harness to confirm behaviour. +module StructuralConformance.ArtifactCatalog.Holes ( + artifactCatalogTransducer, +) where + +import Generated.StructuralConformance.ArtifactCatalog.Domain +import Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections +import Keiki.Builder ((=:)) +import Keiki.Builder qualified as B +import Keiki.Core (HsPred, SymTransducer, inpProj, lit) + +-- HOLE: the transducer body. Reproduce the structure below, replacing each +-- `-- HOLE` line with the keiki symbolic operators it describes. +artifactCatalogTransducer :: + SymTransducer + (HsPred ArtifactCatalogRegs ArtifactCatalogCommand) + ArtifactCatalogRegs + ArtifactCatalogVertex + ArtifactCatalogCommand + ArtifactCatalogEvent +artifactCatalogTransducer = + B.buildTransducer ArtifactCatalogEmpty initialArtifactCatalogRegs isTerminal do + B.from ArtifactCatalogEmpty do + B.onCmd inCtorObserveArtifact $ \d -> B.do + B.requireEq + (inpProj StructuralProjections.structuralProjectionC41ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC49ZC6eZC66ZC6fZC2fZC61ZC72ZC74ZC69ZC66ZC61ZC63ZC74ZC5fZC6bZC65ZC79ZWitness inCtorObserveArtifact #artifact) + (lit "artifact-local-file") + B.slot @"currentArtifact" =: d.artifact + B.slot @"currentGeometry" =: d.geometry + B.slot @"acceptedCount" =: B.reg @"acceptedCount" + B.emit wireArtifactRecorded ArtifactRecordedTermFields{artifact = d.artifact, geometry = d.geometry, accepted = d.accepted} + B.emit wireArtifactAccepted ArtifactAcceptedTermFields{accepted = d.accepted} + B.goto ArtifactCatalogObserved + where + isTerminal = \case + ArtifactCatalogObserved -> True + _ -> False diff --git a/test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs b/test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.HospitalCapacity.ReplayAudit (auditTargets) where + +import Generated.HospitalCapacity.Reservation.EventStream qualified as Reservation +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Reservation.reservationEventStream + , category = Stream.categoryText Reservation.reservationCategory + , mkStream = streamInCategory (Stream.categoryText Reservation.reservationCategory) + } + ] diff --git a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs --- a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs +++ b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs @@ -47,8 +47,14 @@ , schemaVersion = 2 , encode = encodeReservationEvent , decode = parseReservationEvent - , upcasters = [(1, const upcastTransferReservationCreatedV1)] + , upcasters = [(1, upcastRungV1)] } + +upcastRungV1 :: EventType -> Value -> Either Text Value +upcastRungV1 (EventType "TransferReservationCreated") value = upcastTransferReservationCreatedV1 value +-- Kinds whose shape did not change at this rung pass through unchanged; their +-- stamped version is aggregate-global, not their own shape history. +upcastRungV1 _ value = Right value encodeReservationEvent :: ReservationEvent -> Value encodeReservationEvent = \case diff --git a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs --- a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs +++ b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where +import Data.Aeson (eitherDecodeStrict) +import Data.Text.Encoding (encodeUtf8) import Generated.HospitalCapacity.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec) import Generated.HospitalCapacity.Reservation.Domain import HospitalCapacity.Reservation.Holes (reservationTransducer) -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (EventType (..), decodeRaw, eventType) {- | (label, passed). A driver runs these and exits non-zero on any False, @@ -20,14 +24,16 @@ , ("golden round-trip: TransferReservationCreated", roundTrips sampleEventTransferReservationCreated) , ("golden round-trip: TransferReservationConfirmed", roundTrips sampleEventTransferReservationConfirmed) , ("accepts RequestTransferReservation from ReservationUnrequested", acceptRequestTransferReservation) - , ("upcaster wired: a v1 TransferReservationCreated payload decodes through the chain", upcastsTransferReservationCreated) ] + ++ forwardReplayRequestTransferReservation + ++ [ ("golden TransferReservationCreated.v1 decodes", upcastsTransferReservationCreated) + ] roundTrips :: ReservationEvent -> Bool roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e sampleEventTransferReservationCreated :: ReservationEvent -sampleEventTransferReservationCreated = (TransferReservationCreated (TransferReservationCreatedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False "sample")) +sampleEventTransferReservationCreated = (TransferReservationCreated (TransferReservationCreatedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False "sample-triageNote")) sampleEventTransferReservationConfirmed :: ReservationEvent sampleEventTransferReservationConfirmed = (TransferReservationConfirmed (TransferReservationConfirmedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample"))) @@ -38,9 +44,34 @@ Just (v, _, _) -> v == ReservationHeld Nothing -> False +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayRequestTransferReservation :: [(String, Bool)] +forwardReplayRequestTransferReservation = + case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseReservationEvent (eventType reservationCodec event) (encodeReservationEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither reservationTransducer (ReservationUnrequested, initialReservationRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register reservationId", (replayRegs ! #reservationId) == (forwardRegs ! #reservationId)) + , (prefix <> "register hospitalId", (replayRegs ! #hospitalId) == (forwardRegs ! #hospitalId)) + , (prefix <> "register patientAcuity", (replayRegs ! #patientAcuity) == (forwardRegs ! #patientAcuity)) + , (prefix <> "register reservationState", (replayRegs ! #reservationState) == (forwardRegs ! #reservationState)) + ] + where + prefix = "forward/replay equality: RequestTransferReservation from ReservationUnrequested -- " + upcastsTransferReservationCreated :: Bool upcastsTransferReservationCreated = - either - (const False) - (const True) - (decodeRaw reservationCodec (EventType "TransferReservationCreated") 1 (encodeReservationEvent sampleEventTransferReservationCreated)) + case eitherDecodeStrict (encodeUtf8 "{\n \"kind\": \"TransferReservationCreated\",\n \"reservationId\": \"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\",\n \"hospitalId\": \"hosp_01hzy3v7q2e8kaw2m5x0d41n9d\",\n \"commandId\": \"cmd_01hzy3v7q2e8kaw2m5x0d41n9e\",\n \"patientAcuity\": \"red\",\n \"divertStatus\": \"open\",\n \"lifeCriticalOverride\": true\n}\n") of + Left _ -> False + Right payload -> + either + (const False) + (const True) + (decodeRaw reservationCodec (EventType "TransferReservationCreated") 1 payload) diff --git a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs --- a/test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs +++ b/test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs @@ -1,27 +1,29 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} + -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. -module Generated.HospitalCapacity.Reservation.Projection - ( transfer_decisionsProjection - , transfer_decisionsStatusFor - ) where +module Generated.HospitalCapacity.Reservation.Projection ( + transfer_decisionsProjection, + transfer_decisionsStatusFor, +) where +import Data.Text (Text) import Generated.HospitalCapacity.Reservation.Domain import HospitalCapacity.Reservation.Holes (applyTransfer_decisions) -import Data.Text (Text) import Keiro.Projection (InlineProjection (..)) -- The deterministic event->status mapping (hole-kind 3, /mapping/), derived -- from the spec's status-map. The read-model SQL that consumes it lives in -- the hand-owned Holes module (a DB-coupled hole, delegated to codd). +-- WARNING: no readmodel node declares 'transfer_decisions'; unqualified SQL depends on search_path. transfer_decisionsStatusFor :: ReservationEvent -> Maybe Text transfer_decisionsStatusFor = \case - TransferReservationCreated {} -> Just "held" - TransferReservationConfirmed {} -> Just "confirmed" + TransferReservationCreated{} -> Just "held" + TransferReservationConfirmed{} -> Just "confirmed" transfer_decisionsProjection :: InlineProjection ReservationEvent transfer_decisionsProjection = - InlineProjection - { name = "hospital-capacity-transfer_decisions-inline" - , apply = applyTransfer_decisions - } + InlineProjection + { name = "hospital-capacity-transfer_decisions-inline" + , apply = applyTransfer_decisions + } diff --git a/test/conformance-v2/Main.hs b/test/conformance-v2/Main.hs --- a/test/conformance-v2/Main.hs +++ b/test/conformance-v2/Main.hs @@ -8,15 +8,54 @@ -} module Main (main) where -import Control.Monad (forM_, unless) +import Control.Monad (forM, forM_, unless) +import Data.Aeson (Value, eitherDecodeFileStrict') +import Data.List (sort) +import Data.Text qualified as T +import Generated.HospitalCapacity.Reservation.Codec (reservationCodec) import Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) +import Keiro.Codec (EventType (..), decodeRaw) +import System.Directory (listDirectory) import System.Exit (exitFailure) +import Text.Read (readMaybe) main :: IO () main = do - forM_ harnessAssertions $ \(label, ok) -> + goldenAssertions <- loadGoldenAssertions + let assertions = harnessAssertions <> goldenAssertions + forM_ assertions $ \(label, ok) -> putStrLn ((if ok then "PASS " else "FAIL ") <> label) - let failed = [label | (label, ok) <- harnessAssertions, not ok] + let failed = [label | (label, ok) <- assertions, not ok] unless (null failed) $ do putStrLn ("harness: " <> show (length failed) <> " assertion(s) failed") exitFailure + +loadGoldenAssertions :: IO [(String, Bool)] +loadGoldenAssertions = do + files <- sort <$> listDirectory goldenDirectory + forM [file | file <- files, ".json" `T.isSuffixOf` T.pack file] $ \file -> + case parseGoldenName file of + Nothing -> pure ("golden " <> file <> " (invalid fixture filename)", False) + Just (tag, version) -> do + payloadResult <- eitherDecodeFileStrict' (goldenDirectory <> "/" <> file) :: IO (Either String Value) + pure + ( "golden " <> T.unpack tag <> ".v" <> show version + , case payloadResult of + Left _ -> False + Right payload -> + either + (const False) + (const True) + (decodeRaw reservationCodec (EventType tag) version payload) + ) + +goldenDirectory :: FilePath +goldenDirectory = "test/golden-payloads/hospital-capacity/Reservation" + +parseGoldenName :: FilePath -> Maybe (T.Text, Int) +parseGoldenName file = do + stem <- T.stripSuffix ".json" (T.pack file) + let (tagWithMarker, versionText) = T.breakOnEnd ".v" stem + tag = T.dropEnd 2 tagWithMarker + version <- readMaybe (T.unpack versionText) + if T.null tag || T.null versionText then Nothing else Just (tag, version) diff --git a/test/conformance/Generated/HospitalCapacity/ReplayAudit.hs b/test/conformance/Generated/HospitalCapacity/ReplayAudit.hs new file mode 100644 --- /dev/null +++ b/test/conformance/Generated/HospitalCapacity/ReplayAudit.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} + +-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. +-- +-- Deployment contract: +-- * replay-neutral diff: no data audit is required; +-- * affected diff: run AuditTargeted with the emitted affected set +-- against a production copy under the candidate binary; +-- * one-time runtime cutover: run AuditFull; +-- * any non-zero audit exit blocks deployment. +module Generated.HospitalCapacity.ReplayAudit (auditTargets) where + +import Generated.HospitalCapacity.Reservation.EventStream qualified as Reservation +import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory) +import Keiro.Stream qualified as Stream + +auditTargets :: [SomeAuditTarget] +auditTargets = + [ SomeAuditTarget + AuditTarget + { eventStream = Reservation.reservationEventStream + , category = Stream.categoryText Reservation.reservationCategory + , mkStream = streamInCategory (Stream.categoryText Reservation.reservationCategory) + } + ] diff --git a/test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs b/test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs --- a/test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +++ b/test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec. @@ -6,7 +8,7 @@ import Generated.HospitalCapacity.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec) import Generated.HospitalCapacity.Reservation.Domain import HospitalCapacity.Reservation.Holes (reservationTransducer) -import Keiki.Core (defaultValidationOptions, step, validateTransducer) +import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) {- | (label, passed). A driver runs these and exits non-zero on any False, @@ -21,6 +23,7 @@ , ("golden round-trip: TransferReservationConfirmed", roundTrips sampleEventTransferReservationConfirmed) , ("accepts RequestTransferReservation from ReservationUnrequested", acceptRequestTransferReservation) ] + ++ forwardReplayRequestTransferReservation roundTrips :: ReservationEvent -> Bool roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e @@ -36,3 +39,25 @@ case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of Just (v, _, _) -> v == ReservationHeld Nothing -> False + +-- forward/replay equality (plan 147): cross the persisted codec boundary, +-- replay the emitted chain, and compare the final vertex and every register. +forwardReplayRequestTransferReservation :: [(String, Bool)] +forwardReplayRequestTransferReservation = + case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of + Nothing -> [(prefix <> "forward step accepted", False)] + Just (forwardVertex, forwardRegs, emitted) -> + case mapM (\event -> parseReservationEvent (eventType reservationCodec event) (encodeReservationEvent event)) emitted of + Left _ -> [(prefix <> "emitted chain decodes", False)] + Right decodedEvents -> + case applyEventsEither reservationTransducer (ReservationUnrequested, initialReservationRegs) decodedEvents of + Left _ -> [(prefix <> "replay succeeds", False)] + Right (replayVertex, replayRegs) -> + [ (prefix <> "final vertex", replayVertex == forwardVertex) + , (prefix <> "register reservationId", (replayRegs ! #reservationId) == (forwardRegs ! #reservationId)) + , (prefix <> "register hospitalId", (replayRegs ! #hospitalId) == (forwardRegs ! #hospitalId)) + , (prefix <> "register patientAcuity", (replayRegs ! #patientAcuity) == (forwardRegs ! #patientAcuity)) + , (prefix <> "register reservationState", (replayRegs ! #reservationState) == (forwardRegs ! #reservationState)) + ] + where + prefix = "forward/replay equality: RequestTransferReservation from ReservationUnrequested -- "