diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,179 @@ +# Changelog + +All notable changes to `keiro-dsl` are recorded here. The format follows +[Keep a Changelog](https://keepachangelog.com/), and the package follows the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [Unreleased] + +_No unreleased changes._ + +## 0.2.0.0 — 2026-07-13 + +### Breaking Changes + +- The process `saga` clause is now `saga category ""`, + replacing `saga stream="-" <> correlationId`. Categories are + validated (`SagaCategoryIllegal`) against the same rules as + `Keiro.Stream.category`: non-empty, not `$all`, no `-` (Kiroku's category/id + boundary), no whitespace or control characters, and no `:` (reserved for the + `wf:` workflow stream family). Generated process and router fills now + build saga streams with `entityStream` and a typed category constant instead of + splicing a string prefix. +- `process` nodes must now declare node-level `rejected => ` and + `poison => ` clauses (`halt`, `deadLetter`, or `skip`), and every timer + `fire` disposition must carry an `on-ambiguous` arm alongside `on-ok`, + `on-reject`, `on-error`, and `not-mine`. Mapping `on-ambiguous => Fired` is + rejected (`AmbiguousMarkedBenign`): `CommandAmbiguous` means several aggregate + edges matched, and is never a benign success. +- Identifier lexemes are restricted to ASCII, and the validator now enforces + per-category Haskell hygiene: constructor-position names must be + constructor-safe (`IdentNotConstructorSafe`), no identifier may be a Haskell + keyword (`IdentHaskellKeyword`), and generated vertex constructors may not + collide (`VertexCtorCollision`). Specs that previously scaffolded to + uncompilable Haskell are now rejected at `check`. +- All numeric literal sites parse through `Integer` and fail with a positioned + diagnostic when the value exceeds `maxBound :: Int`, instead of silently + wrapping. `maxBound` itself still parses exactly. +- Duplicate singleton blocks and duplicate `goto` clauses are reported at their + second occurrence rather than being silently accepted with a last-one-wins + reading; a missing `goto` is now anchored to its transition. +- `Text` registers require a quoted initial, and a register whose type is an enum + or the aggregate's vertex type must start at a declared constructor or state. + The scaffolder refuses the run rather than emitting a broken initial. +- Validation is substantially stricter, so specs that checked under 0.1.0.0 may + now be rejected: duplicate node, command, event, enum-constructor, enum-wire and + id-prefix names; dangling aggregate, projection, timer, workflow, signal and + operation references; non-total or unresolved `rule` domains; duplicate workflow + replay labels; incomplete or shadowed disposition tables; duplicate and dangling + status-map keys; emit/intake topic-affinity mismatch; workqueue + `queueRef`/table/DLQ divergence; unresolved dispatch dedup queues and fields; + invalid process timer ceilings; and write targets that are not registers. +- `keiro-dsl scaffold` now plans the entire module set before writing any byte, + and refuses the run on module-path collisions, self-firewall breaches, or + unlowerable spec content. It also refuses to overwrite a file on a `Generated` + path that lacks the `@generated` banner; pass the new + `--force-generated-overwrite` flag to override. +- `keiro-dsl diff` gained a `WARNING:` tier, and its change lines now read + ` : ` rather than always saying `event`. Only + `BREAKING:` changes exit non-zero. + +### New Features + +- Added a first-class `readmodel` node declaring `table`, `schema`, a typed + `columns` block, `version`, captured `shape`, `consistency`, `scope`, `feed` + (`inline` or `subscription`), and `subscription`. The validator owns a closed + column-type vocabulary (`text`, `int`, `bigint`, `bool`, `timestamptz`, `jsonb`, + `numeric`), detects shape-hash drift against the declared columns, rejects + `Strong` + `inline` (no subscription worker advances the cursor a strong read + waits on), rejects `scope` without `Strong`, and rejects an `inline` model that + no aggregate projection feeds. `scaffold` emits `ReadModel` and `ReadModelTable` + generated modules plus `ReadModelHoles`. Aggregate `projection` consistency is + now optional and must agree with the read-model node when one exists; a + projection with no `readmodel` node warns that registration, schema identity, + and rebuild helpers are unavailable. +- Query operations and PGMQ dispatch source/dedup read-model references now + actually resolve against declared nodes — these were explicitly deferred no-ops + in 0.1.0.0. Query `consistency` must be `Strong`, `Eventual`, or `PositionWait`, + and a dispatch dedup field must be a column of the named model. +- Added the `router` node for stateless content-based routing: `input`, `key`, + `resolve stable via read-model row { ... }` (or `via hole`), `target`, + `projections`, `dispatch-each`, a runtime-owned `dispatch-id` strategy keyed on + target stream name and occurrence, and node-level `rejected`/`poison` policies. + Validation resolves the target aggregate, its command and command fields, the + key field, and the read-model reference, and confines dispatch bindings to the + `input.` and `resolved.` scopes plus quoted literals. `scaffold` emits + `Router`/`RouterHarness` generated modules with `RouterHoles`/`RouterValue` + stubs, and `keiro-dsl new router` prints a starter. +- Added node-level `rejected` and `poison` worker policies on `process` and + `router` nodes, reconciled against the per-dispatch `on-failed` arms: a dispatch + declaring `DeadLetter` under a node that does not is a `PolicyContradiction`, + divergent `on-failed` actions within one node are rejected because the runtime + applies a single `RejectedCommandPolicy` to the whole failure group, and an + unacknowledged `rejected => deadLetter` warns. +- Added aggregate `snapshot every ` / `snapshot on-terminal` with a captured + `state-codec version= shape-hash="..."` fixture, lowered into the generated + aggregate modules and pinned against the live runtime. Intervals below 1, and + empty or zero-version codec fixtures, are rejected. +- Added workqueue `ordering` (`unordered`, `fifo-throughput`, `fifo-round-robin`), + `group key from via `, and provisioning (standard, `unlogged`, + partitioned). The validator rejects FIFO without a group key, a group key + without FIFO, and an empty partition spec, and flags unlogged durability; the + generated `QueuePolicy` is pinned to the live pgmq configuration types. +- Added intake `persist = full-envelope | dedupe-only`, lowered to the live + `InboxPersistence` value and wired through `runInboxTransactionWith`. +- Added a durable-workflow evolution surface: guarded `patch { ... }` blocks + and a terminal `continueAsNew `, lowered into the workflow run + options. Duplicate and malformed patch ids, and a non-terminal `continueAsNew`, + are rejected. +- Added a `partial` token on `status-map`, so an intentionally incomplete + event-to-status mapping is expressible instead of failing the totality rule. +- Publisher backoff accepts optional `max=` and `multiplier=`, and exponential + backoff now lowers to `ExponentialBackoff ExponentialBackoffOptions{..}` with + faithful duration units. +- Rebuilt `diff` on an exhaustive node-family registry: every `Node` constructor + either has a differ or carries a recorded out-of-scope rationale, so a new node + kind can no longer be silently treated as safe. Classification now covers + aggregate decode evolution through command indirection (field type, removal, + wire spelling, enum add/drop, schema-version regression, old-anchored upcaster + continuity, undeprecation), contract topic/schema-version/discriminator/field/ + event changes, workqueue payload, identity, ordering and provisioning changes, + process input and timer-window changes, intake decode posture, dedupe identity + and persistence, emit mapping and ordering, publisher policy, workflow shape, + body, patch and continue-as-new seed changes, read-model + version/shape/feed/consistency evolution, projection and id-prefix re-keying, + router stable-name changes, and dispatch retargeting. +- `scaffold` now writes a versioned per-context record + (`keiro-dsl-scaffold-record..txt`) and reports still-present modules + made stale by node, layout, or `--module-root` changes. It never deletes + generated or hand-owned files. +- Diagnostics carry row-level source locations, so validator-owned rows + (dispositions, status maps, timers, dispatches) are anchored precisely instead + of at the enclosing node. + +### Bug Fixes + +- String literals now decode and re-render the closed DSL escape set, so topics, + emit maps, and quoted field bindings survive a parse/pretty-print round trip + instead of being corrupted. +- The scaffolder escapes payload literal splices, closing a template-injection + path where a quoted spec literal could break out of the generated Haskell + string. Its status-map and harness lowering is now total. +- Generated `Stream` and stream-category imports are emitted in the + repository-standard post-qualified (`ImportQualifiedPost`) form. +- The self-firewall is derived from Keiki's exported surface as a single + token-aware scan, rather than a hand-maintained substring list that both missed + operators and produced false positives. + +### Other Changes + +- Added conformance suites that round-trip every node family, compile every + `keiro-dsl new ` starter, cold-start the new read-model, router, snapshot, + queue-ordering, and workflow-rotation surfaces, and exercise the generated + read-model and router modules against the live runtime. +- Test fixtures and conformance corpora resolve from either the package root or + the repository root. + +## 0.1.0.0 — 2026-07-05 + +Initial Hackage release. + +### Breaking Changes + +- Renamed the typed-spec file extension from `.kdsl` to `.keiro` before the first + public release. + +### New Features + +- Added grammar, parser, pretty-printer, validator, diff engine, scaffold + generator, harness emitter, and CLI for typed `.keiro` service specs. +- Added aggregate, process manager, durable timer, integration contract, inbox, + publisher, PGMQ workqueue, workflow, and operation nodes. +- Added configurable module placement, build-wiring manifests, self-firewall + checks, post-scaffold reports, per-iteration ergonomics, and `new ` + starter skeletons. +- Generated validated event streams compatible with Keiro's command boundaries. + +### Bug Fixes + +- Tolerated formatter comma style in scaffold conformance tests. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,190 @@ +{- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@ +subcommands; a later milestone adds @scaffold@ to the same +optparse-applicative command tree. +-} +module Main (main) where + +import Control.Monad (when) +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.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.Skeleton (skeletonFor) +import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec) +import Options.Applicative +import System.Directory (canonicalizePath) +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (makeRelative, 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 + | New String + +main :: IO () +main = run =<< execParser opts + where + opts = + info + (commands <**> helper) + (fullDesc <> progDesc "keiro-dsl: a typed-specification toolchain for keiro services") + +commands :: Parser Command +commands = + subparser + ( command + "parse" + (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")) + <> command + "scaffold" + (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <**> 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")) + <> 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)")) + ) + +outOpt :: Parser FilePath +outOpt = strOption (long "out" <> metavar "DIR" <> help "Output directory for the scaffolded modules") + +moduleRootOpt :: Parser String +moduleRootOpt = strOption (long "module-root" <> metavar "PREFIX" <> help "Namespace prefix for emitted modules, e.g. Acme or Acme.Services (overrides the spec's module clause)") + +collocateSwitch :: Parser Bool +collocateSwitch = switch (long "collocate" <> help "Place the generated layer as a leaf under the domain (..Generated) instead of a parallel Generated.* tree") + +forceGeneratedOverwriteSwitch :: Parser Bool +forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner") + +emitSwitch :: Parser Bool +emitSwitch = switch (long "emit" <> help "On success, pretty-print the parsed spec to stdout (folds parse + check into one call)") + +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)") + +fileArg :: Parser FilePath +fileArg = argument str (metavar "FILE" <> help "Path to a .keiro spec (use /dev/stdin for stdin)") + +kindArg :: Parser String +kindArg = argument str (metavar "KIND" <> help "Node kind to scaffold a starter spec for") + +run :: Command -> IO () +run (Parse fp) = do + input <- TIO.readFile fp + case parseSpec fp input of + Left err -> do + hPutStrLn stderr (T.unpack err) + exitFailure + Right spec -> TIO.putStrLn (renderSpec spec) +run (Check fp emit) = do + input <- TIO.readFile fp + case parseSpec fp input of + Left err -> do + hPutStrLn stderr (T.unpack err) + exitFailure + Right spec -> do + let diags = validateSpec spec + 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 + input <- TIO.readFile fp + case parseSpec fp input of + Left err -> do + hPutStrLn stderr (T.unpack err) + exitFailure + Right spec -> do + -- Validation gate: never scaffold an invalid spec. Abort on any + -- error-severity diagnostic before writing a single module. + let diags = validateSpec spec + 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 + 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) +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 + -- Resolve the spec to a repo-relative path so `git show :` works. + let dir = takeDirectory fp + rootRes <- git dir ["rev-parse", "--show-toplevel"] + case rootRes of + Left err -> hPutStrLn stderr err >> exitFailure + Right rootRaw -> do + let repoRoot = trim rootRaw + absFp <- canonicalizePath fp + let relPath = makeRelative repoRoot absFp + oldRes <- git repoRoot ["show", ref <> ":" <> relPath] + case oldRes of + Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure + Right oldText -> do + newText <- TIO.readFile fp + case (,) <$> parseSpec (ref <> ":" <> relPath) (T.pack oldText) <*> parseSpec fp newText of + Left perr -> hPutStrLn stderr (T.unpack perr) >> exitFailure + Right (oldSpec, newSpec) -> do + let changes = diffSpecs oldSpec newSpec + mapM_ (putStrLn . renderChange) changes + if any isBreaking changes 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) + +-- | Run git in a directory, returning trimmed stdout or stderr. +git :: FilePath -> [String] -> IO (Either String String) +git dir args = do + (ec, out, err) <- readProcessWithExitCode "git" (["-C", dir] <> args) "" + pure $ case ec of + ExitSuccess -> Right out + ExitFailure _ -> Left (if null err then out else err) + +trim :: String -> String +trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String)) + +{- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a +'Context'. Precedence is CLI flag > spec clause > built-in default. +-} +mkContext :: Maybe String -> Bool -> Spec -> Context +mkContext cliRoot cliCollocate spec = + Context + { contextName = specContext spec + , moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot + , placement = + if cliCollocate + then CollocatedLeaf + else fromMaybe GeneratedPrefix (specLayout spec) + } diff --git a/keiro-dsl.cabal b/keiro-dsl.cabal new file mode 100644 --- /dev/null +++ b/keiro-dsl.cabal @@ -0,0 +1,583 @@ +cabal-version: 3.0 +name: keiro-dsl +version: 0.2.0.0 +synopsis: Typed specification toolchain for keiro services +description: + keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro + service: a parser + checker + scaffolder + harness emitter. It emits the + symbol-free deterministic layer plus typed holes, never a keiki symbolic + operator (the firewall invariant). + +license: BSD-3-Clause +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Development +build-type: Simple +tested-with: GHC >=9.12 && <9.13 +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +common shared + default-language: GHC2024 + default-extensions: + LambdaCase + OverloadedStrings + +library + import: warnings, shared + hs-source-dirs: src + exposed-modules: + Keiro.Dsl.Diff + Keiro.Dsl.Grammar + Keiro.Dsl.Harness + Keiro.Dsl.Manifest + Keiro.Dsl.Parser + Keiro.Dsl.PrettyPrint + Keiro.Dsl.ReadModelShape + Keiro.Dsl.Scaffold + Keiro.Dsl.ScaffoldRecord + Keiro.Dsl.ScaffoldRun + Keiro.Dsl.Skeleton + 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 + +executable keiro-dsl + import: warnings, shared + hs-source-dirs: app + main-is: Main.hs + build-depends: + , base >=4.21 && <5 + , directory >=1.3 + , filepath >=1.4 + , keiro-dsl + , optparse-applicative >=0.18 + , process >=1.6 + , text >=2.1 + +test-suite keiro-dsl-test + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base >=4.21 && <5 + , containers >=0.6 + , directory >=1.3 + , filepath >=1.4 + , hspec >=2.11 + , keiro-dsl + , QuickCheck >=2.14 + , text >=2.1 + +-- Conformance: proves the scaffolded Generated modules plus a hand-filled +-- Holes.hs compile against keiki/keiro and that the filled transducer passes +-- keiki's validator and the codec round-trips. The Generated.* modules under +-- test/conformance/ are byte-identical to `keiro-dsl scaffold` output (pinned +-- by the scaffold-conformance test in keiro-dsl-test). +test-suite keiro-dsl-conformance + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Reservation.Codec + Generated.HospitalCapacity.Reservation.Domain + Generated.HospitalCapacity.Reservation.EventStream + Generated.HospitalCapacity.Reservation.Harness + Generated.HospitalCapacity.Reservation.Projection + HospitalCapacity.Reservation.Holes + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiki >=0.2 && <0.3 + , keiro + , text >=2.1 + +-- 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. +test-suite keiro-dsl-conformance-snapshot + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-snapshot + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Reservation.Codec + Generated.HospitalCapacity.Reservation.Domain + Generated.HospitalCapacity.Reservation.EventStream + HospitalCapacity.Reservation.Holes + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiki >=0.2 && <0.3 + , keiro + , text >=2.1 + +-- EP-106 M6: every distinct `new ` skeleton is scaffolded into this +-- committed tree. Compiling the union proves a starter that passes `check` +-- cannot emit syntactically or type-invalid Haskell. +test-suite keiro-dsl-conformance-skeletons + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-skeletons + main-is: Main.hs + other-modules: + SkelAggregate.Generated.MyService.Thing.Codec + SkelAggregate.Generated.MyService.Thing.Domain + SkelAggregate.Generated.MyService.Thing.EventStream + SkelAggregate.Generated.MyService.Thing.Harness + SkelAggregate.Generated.MyService.Thing.Projection + SkelAggregate.MyService.Thing.Holes + SkelContract.Generated.MyService.MyContract.Contract + SkelEmit.Generated.MyService.MyContract.Contract + SkelEmit.Generated.MyService.ThingPublisher.Publisher + SkelIntake.Generated.MyService.MyContract.Contract + SkelIntake.Generated.MyService.ThingInbox.Inbox + SkelProcess.Generated.MyService.Hospital.Codec + SkelProcess.Generated.MyService.Hospital.Domain + SkelProcess.Generated.MyService.Hospital.EventStream + SkelProcess.Generated.MyService.Hospital.Harness + SkelProcess.Generated.MyService.Hospital.Projection + SkelProcess.Generated.MyService.HospitalSurge.Process + SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness + SkelProcess.Generated.MyService.Surge.Codec + SkelProcess.Generated.MyService.Surge.Domain + SkelProcess.Generated.MyService.Surge.EventStream + SkelProcess.Generated.MyService.Surge.Harness + SkelProcess.Generated.MyService.Surge.Projection + SkelProcess.MyService.Hospital.Holes + SkelProcess.MyService.HospitalSurge.ProcessHoles + SkelProcess.MyService.Surge.Holes + SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModel + 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.QueuePolicy + SkelQueue.Generated.MyService.Transfer_decisions.ReadModel + SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness + SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable + SkelQueue.MyService.Accepted_transfer_needs.ReadModelHoles + SkelQueue.MyService.Transfer_decisions.ReadModelHoles + SkelRouter.Generated.MyService.Page.Codec + SkelRouter.Generated.MyService.Page.Domain + SkelRouter.Generated.MyService.Page.EventStream + SkelRouter.Generated.MyService.Page.Harness + SkelRouter.Generated.MyService.Page.Projection + SkelRouter.Generated.MyService.PagingRouter.Router + SkelRouter.Generated.MyService.PagingRouter.RouterHarness + SkelRouter.MyService.Page.Holes + SkelRouter.MyService.PagingRouter.RouterHoles + SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts + SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , containers + , effectful-core + , hasql-transaction + , keiki >=0.2 && <0.3 + , keiro + , keiro-pgmq + , kiroku-store + , shibuya-core + , text >=2.1 + , time + , uuid + +-- EP-7 cold-start: a fresh `subscription` aggregate authored from only the skill +-- notation, scaffolded + hand-filled, compiling against keiki/keiro with a green +-- spec-derived harness — proof the authoring loop closes on a non-corpus spec. +test-suite keiro-dsl-conformance-coldstart + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-coldstart + main-is: Main.hs + other-modules: + Billing.Subscription.Holes + Generated.Billing.Subscription.Codec + Generated.Billing.Subscription.Domain + Generated.Billing.Subscription.EventStream + Generated.Billing.Subscription.Harness + Generated.Billing.Subscription.Projection + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiki >=0.2 && <0.3 + , keiro + , text >=2.1 + +-- Contract codec conformance (EP-4): the scaffolded self-contained contract +-- payload ADT + codec, compiled + round-tripped per event type. +test-suite keiro-dsl-conformance-contract + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-contract + main-is: Main.hs + other-modules: Generated.HospitalCapacity.Emergency.Contract + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , text >=2.1 + +-- EP-4 intake runtime conformance: the scaffolded Inbox disposition + dedupe +-- policy compiled against the LIVE Keiro.Inbox.Types (InboxResult / dedupe). +test-suite keiro-dsl-conformance-intake-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-intake-runtime + main-is: Main.hs + other-modules: Generated.HospitalCapacity.IncidentInbox.Inbox + build-depends: + , base >=4.21 && <5 + , keiro + +-- EP-4 M5 full-service conformance: a complete integration service — scaffolded +-- inbox dedupe + a filled inbox transaction runner and outbox IntegrationProducer +-- — compiled against the live keiro runtime (Inbox / Outbox / Kiroku.Store). +test-suite keiro-dsl-conformance-intake-full + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-intake-full + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.IncidentInbox.Inbox + HospitalCapacity.IncidentInbox.Integration + + build-depends: + , base >=4.21 && <5 + , effectful-core + , hasql-transaction + , keiro + , kiroku-store >=0.3 && <0.4 + +-- EP-4 publisher runtime conformance: the scaffolded Publisher config compiled +-- against the LIVE Keiro.Outbox.Types (OrderingPolicy / BackoffSchedule). +test-suite keiro-dsl-conformance-publisher-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-publisher-runtime + main-is: Main.hs + other-modules: Generated.HospitalCapacity.HospitalPublisher.Publisher + build-depends: + , base >=4.21 && <5 + , keiro + +-- pgmq Job codec conformance (EP-5): the scaffolded self-contained Job payload +-- record + field->wire codec, compiled + round-tripped. +test-suite keiro-dsl-conformance-queue + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-queue + main-is: Main.hs + other-modules: Generated.HospitalCapacity.Reservation_work.Queue + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , text >=2.1 + +-- EP-5 pgmq runtime conformance: the scaffolded QueuePolicy (RetryPolicy + +-- JobOutcome disposition) compiled against the LIVE Keiro.PGMQ.Job runtime. +test-suite keiro-dsl-conformance-queue-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-queue-runtime + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Reservation_work.Queue + Generated.HospitalCapacity.Reservation_work.QueuePolicy + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiro-dsl + , keiro-pgmq + , pgmq-config + , pgmq-core + , text >=2.1 + +-- EP-107 read-model runtime conformance: the scaffolded ReadModel record, +-- registration/rebuild helpers, AsyncProjection, facts harness, and a filled +-- qualified-table query compiled against the live Keiro.ReadModel API. +test-suite keiro-dsl-conformance-readmodel-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-readmodel-runtime + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Transfer_decisions.ReadModel + Generated.HospitalCapacity.Transfer_decisions.ReadModelHarness + Generated.HospitalCapacity.Transfer_decisions.ReadModelTable + HospitalCapacity.Transfer_decisions.ReadModelHoles + + build-depends: + , base >=4.21 && <5 + , effectful-core + , hasql-transaction + , keiro + , kiroku-store + , text >=2.1 + +-- EP-5 M5 full-service conformance: a complete pgmq dispatch service — scaffolded +-- Job codec + retry policy + a filled worker handler assembled into a live +-- Keiro.PGMQ.Job.Job value — compiled against keiro-pgmq. +test-suite keiro-dsl-conformance-dispatch-full + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-dispatch-full + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Reservation_work.Queue + Generated.HospitalCapacity.Reservation_work.QueuePolicy + HospitalCapacity.ReservationWork.WorkqueueJob + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , effectful-core + , keiro-pgmq + , text >=2.1 + +-- Workflow facts harness (EP-6): the scaffolded self-contained WorkflowFacts +-- module asserted against a hand-written expectation (mutation-pinnable). +test-suite keiro-dsl-conformance-workflow + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-workflow + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.HospitalTransferReservation.WorkflowFacts + + build-depends: base >=4.21 && <5 + +-- EP-6 workflow runtime conformance: the scaffolded WorkflowRuntime +-- (WorkflowName + awakeable-id derivation) compiled against the LIVE +-- Keiro.Workflow; pins the await<->signal id match over deterministicAwakeableId. +test-suite keiro-dsl-conformance-workflow-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-workflow-runtime + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime + + build-depends: + , base >=4.21 && <5 + , containers + , keiro + , text >=2.1 + +-- EP-3 M5 full-service conformance: a complete process service — the scaffolded +-- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a +-- filled ProcessManager handle — compiled against the live keiro/keiki runtime. +test-suite keiro-dsl-conformance-process-full + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-process-full + main-is: Main.hs + other-modules: + Generated.SurgeDemo.Hospital.Codec + Generated.SurgeDemo.Hospital.Domain + Generated.SurgeDemo.Hospital.EventStream + Generated.SurgeDemo.Hospital.Projection + Generated.SurgeDemo.Surge.Codec + Generated.SurgeDemo.Surge.Domain + Generated.SurgeDemo.Surge.EventStream + Generated.SurgeDemo.Surge.Projection + Generated.SurgeDemo.SurgeFlow.Process + SurgeDemo.Hospital.Holes + SurgeDemo.Surge.Holes + SurgeDemo.SurgeFlow.Manager + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiki >=0.2 && <0.3 + , keiro + , shibuya-core + , text >=2.1 + , time >=1.12 + , uuid >=1.3 + +-- EP-6 M5 full-service conformance: a complete durable workflow — scaffolded +-- WorkflowRuntime + a filled ordered step/await body — compiled against the +-- live Keiro.Workflow effect. +test-suite keiro-dsl-conformance-workflow-full + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-workflow-full + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime + HospitalCapacity.HospitalTransferReservation.WorkflowBody + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , containers + , effectful-core + , keiro + , text >=2.1 + +-- EP-3 process runtime conformance: the scaffolded Process module's +-- deterministic wiring (timer-request builder + fire disposition) compiled +-- against the LIVE keiro runtime (Keiro.Timer / Keiro.Command), not just text. +test-suite keiro-dsl-conformance-process-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-process-runtime + main-is: Main.hs + other-modules: Generated.HospitalCapacity.HospitalSurge.Process + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiro + , keiro-dsl + , shibuya-core + , text >=2.1 + , time >=1.12 + , uuid >=1.3 + +-- EP-108 router runtime conformance: generated policy lowering and the live +-- target-keyed deterministic id contract. +test-suite keiro-dsl-conformance-router-runtime + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-router-runtime + main-is: Main.hs + other-modules: + Generated.IncidentPaging.PagingRouter.Router + Generated.IncidentPaging.PagingRouter.RouterHarness + + build-depends: + , base >=4.21 && <5 + , keiro + , kiroku-store + , shibuya-core + , text >=2.1 + , uuid >=1.3 + +-- EP-108 generated router-facts harness with hand-written expectations. +test-suite keiro-dsl-conformance-router + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-router + main-is: Main.hs + other-modules: Generated.IncidentPaging.PagingRouter.RouterHarness + build-depends: base >=4.21 && <5 + +-- EP-108 filled-router conformance: scaffolded Page aggregate plus a filled +-- resolver and Router value compiled against the live API. +test-suite keiro-dsl-conformance-router-full + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-router-full + main-is: Main.hs + other-modules: + Generated.IncidentPaging.Page.Codec + Generated.IncidentPaging.Page.Domain + Generated.IncidentPaging.Page.EventStream + Generated.IncidentPaging.PagingRouter.Router + Generated.IncidentPaging.PagingRouter.RouterHarness + IncidentPaging.Page.Holes + IncidentPaging.PagingRouter.RouterValue + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , effectful-core + , keiki >=0.2 && <0.3 + , keiro + , shibuya-core + , text >=2.1 + +-- MP-15/EP-110 M6 cold-start: a fresh agent, given only the authoring skill +-- and feature sentence, produced this aggregate + readmodel + router service. +-- The component compiles generated output and hand-owned fills together and +-- runs the aggregate, readmodel, router-policy, and live Router assertions. +test-suite keiro-dsl-conformance-newsurface + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-newsurface + main-is: Main.hs + other-modules: + Generated.TransferRouting.Hospital.Codec + Generated.TransferRouting.Hospital.Domain + Generated.TransferRouting.Hospital.EventStream + Generated.TransferRouting.Hospital.Harness + Generated.TransferRouting.Hospital.Projection + Generated.TransferRouting.Hospital_load.ReadModel + Generated.TransferRouting.Hospital_load.ReadModelHarness + Generated.TransferRouting.Hospital_load.ReadModelTable + Generated.TransferRouting.HospitalTransferRouter.Router + Generated.TransferRouting.HospitalTransferRouter.RouterHarness + TransferRouting.Hospital.Holes + TransferRouting.Hospital_load.ReadModelHoles + TransferRouting.HospitalTransferRouter.RouterHoles + TransferRouting.HospitalTransferRouter.RouterValue + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , effectful-core + , hasql-transaction + , keiki >=0.2 && <0.3 + , keiro + , kiroku-store + , shibuya-core + , text >=2.1 + +-- Process-manager facts harness (EP-3 M4): the self-contained, firewall-clean +-- ProcessHarness module scaffolded from hospital-surge.keiro, compiled + run to +-- prove the scaffolder lowered the spec's deterministic process/timer decisions +-- faithfully. (The runtime-coupled Process/ProcessHoles modules are emitted to +-- disk but not in this component; their live conformance is the M5 step.) +test-suite keiro-dsl-conformance-process + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-process + main-is: Main.hs + other-modules: Generated.HospitalCapacity.HospitalSurge.ProcessHarness + build-depends: + , base >=4.21 && <5 + , text >=2.1 + +-- Conformance for the evolved (v2) Reservation aggregate: proves the scaffolded +-- Codec schemaVersion=2 + upcasters wiring compiles and that the filled upcaster +-- migrates a v1-tagged payload through the chain (the harness "upcaster wired" +-- assertion). These sources are raw `keiro-dsl scaffold` output of +-- reservation-v2.keiro plus a hand-filled Holes.hs. +test-suite keiro-dsl-conformance-v2 + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-v2 + main-is: Main.hs + other-modules: + Generated.HospitalCapacity.Reservation.Codec + Generated.HospitalCapacity.Reservation.Domain + Generated.HospitalCapacity.Reservation.EventStream + Generated.HospitalCapacity.Reservation.Harness + Generated.HospitalCapacity.Reservation.Projection + HospitalCapacity.Reservation.Holes + + build-depends: + , aeson >=2.2 + , base >=4.21 && <5 + , keiki >=0.2 && <0.3 + , keiro + , text >=2.1 diff --git a/src/Keiro/Dsl/Diff.hs b/src/Keiro/Dsl/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Diff.hs @@ -0,0 +1,1195 @@ +{- | The spec evolution differ. 'diffSpecs' compares an /old/ and a /new/ 'Spec' +and classifies changes over the persisted decode and identity surfaces. + +Changes are __ADDITIVE__ when they preserve stored data, __WARNING__ when they +change forward behaviour without invalidating persisted data, and __BREAKING__ +when stored payloads may stop decoding or persisted identities may be re-keyed. +The @diff --since@ CLI exits non-zero only when a breaking change is present. + +Every 'Node' constructor maps to a 'NodeFamily', and 'familyRegistry' contains +exactly one entry for each family. A family is either handled by an explicit +differ or carries a non-empty out-of-scope rationale. This makes omissions +visible when the grammar grows instead of silently treating new node kinds as +safe. +-} +module Keiro.Dsl.Diff ( + Change (..), + ChangeKind (..), + isBreaking, + isAdvisory, + diffSpecs, + DiffEnv (..), + NodeFamily (..), + familyOf, + FamilyDiff (..), + familyRegistry, + Paired (..), + pairByName, + readModelDiff, + classifyWorkflowBody, +) where + +import Data.List (find, (\\)) +import Data.Maybe (isJust, isNothing, 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 (DiagnosticCode (..)) + +-- | A classified spec change. +data Change + = Additive ChangeKind + | Advisory ChangeKind + | Breaking ChangeKind + deriving stock (Eq, Show) + +data ChangeKind = ChangeKind + { ckNode :: !Name + , ckFacet :: !Text + , ckSubject :: !Text + , ckCode :: !(Maybe DiagnosticCode) + , ckDetail :: !Text + } + deriving stock (Eq, Show) + +isBreaking :: Change -> Bool +isBreaking (Breaking _) = True +isBreaking (Additive _) = False +isBreaking (Advisory _) = False + +isAdvisory :: Change -> Bool +isAdvisory (Advisory _) = True +isAdvisory (Additive _) = False +isAdvisory (Breaking _) = False + +-- | Both specs supplied to a node-family differ, always old then new. +data DiffEnv = DiffEnv + { deOld :: !Spec + , deNew :: !Spec + } + deriving stock (Eq, Show) + +-- | The closed set of node families currently present in 'Node'. +data NodeFamily + = FamAggregate + | FamProcess + | FamRouter + | FamContract + | FamIntake + | FamEmit + | FamPublisher + | FamWorkqueue + | FamPgmqDispatch + | FamReadModel + | FamWorkflow + | FamOperation + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Total by construction: one explicit arm per 'Node' constructor. +familyOf :: Node -> NodeFamily +familyOf (NAggregate _) = FamAggregate +familyOf (NProcess _) = FamProcess +familyOf (NRouter _) = FamRouter +familyOf (NContract _) = FamContract +familyOf (NIntake _) = FamIntake +familyOf (NEmit _) = FamEmit +familyOf (NPublisher _) = FamPublisher +familyOf (NWorkqueue _) = FamWorkqueue +familyOf (NPgmqDispatch _) = FamPgmqDispatch +familyOf (NReadModel _) = FamReadModel +familyOf (NWorkflow _) = FamWorkflow +familyOf (NOperation _) = FamOperation + +-- | A family either has a differ or an explicit reason it is not compared. +data FamilyDiff + = DiffFamily (DiffEnv -> [Change]) + | OutOfDiffScope Text + +-- | Pair the old and new declarations of one node family by stable name. +data Paired n = Paired + { prMatched :: ![(n, n)] + , prAdded :: ![n] + , prRemoved :: ![n] + } + deriving stock (Eq, Show) + +pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n +pairByName project nameOf env = + Paired + { prMatched = + [ (oldNode, newNode) + | newNode <- newNodes + , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes] + ] + , prAdded = + [ newNode + | newNode <- newNodes + , isNothing (find ((== nameOf newNode) . nameOf) oldNodes) + ] + , prRemoved = + [ oldNode + | oldNode <- oldNodes + , isNothing (find ((== nameOf oldNode) . nameOf) newNodes) + ] + } + where + oldNodes = mapMaybe project (specNodes (deOld env)) + newNodes = mapMaybe project (specNodes (deNew env)) + +{- | Registry invariant: every 'Node' constructor maps to a family via the +total 'familyOf' case, and every family occurs exactly once here. The unit +suite enforces registry coverage and non-empty out-of-scope rationales. +-} +familyRegistry :: [(NodeFamily, FamilyDiff)] +familyRegistry = + [ (FamAggregate, DiffFamily aggregateDiff) + , (FamProcess, DiffFamily processDiff) + , (FamRouter, DiffFamily routerDiff) + , (FamContract, DiffFamily contractDiff) + , (FamIntake, DiffFamily intakeDiff) + , (FamEmit, DiffFamily emitDiff) + , (FamPublisher, DiffFamily publisherDiff) + , (FamWorkqueue, DiffFamily workqueueDiff) + , (FamPgmqDispatch, DiffFamily pgmqDispatchDiff) + , (FamReadModel, DiffFamily readModelDiff) + , (FamWorkflow, DiffFamily workflowDiff) + , (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns") + ] + +diffSpecs :: Spec -> Spec -> [Change] +diffSpecs old new = + sharedDeclarationDiff env + ++ concatMap (runFamily env . snd) familyRegistry + where + env = DiffEnv old new + +runFamily :: DiffEnv -> FamilyDiff -> [Change] +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. +sharedDeclarationDiff :: DiffEnv -> [Change] +sharedDeclarationDiff env = enumDiff env ++ idDiff env + +nodeAggregate :: Node -> Maybe Aggregate +nodeAggregate (NAggregate a) = Just a +nodeAggregate _ = Nothing + +nodeProcess :: Node -> Maybe ProcessNode +nodeProcess (NProcess process) = Just process +nodeProcess _ = Nothing + +nodeRouter :: Node -> Maybe RouterNode +nodeRouter (NRouter router) = Just router +nodeRouter _ = Nothing + +nodeContract :: Node -> Maybe ContractNode +nodeContract (NContract contract) = Just contract +nodeContract _ = Nothing + +nodeIntake :: Node -> Maybe IntakeNode +nodeIntake (NIntake intake) = Just intake +nodeIntake _ = Nothing + +nodeEmit :: Node -> Maybe EmitNode +nodeEmit (NEmit emit) = Just emit +nodeEmit _ = Nothing + +nodePublisher :: Node -> Maybe PublisherNode +nodePublisher (NPublisher publisher) = Just publisher +nodePublisher _ = Nothing + +nodeWorkqueue :: Node -> Maybe WorkqueueNode +nodeWorkqueue (NWorkqueue workqueue) = Just workqueue +nodeWorkqueue _ = Nothing + +nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode +nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch +nodePgmqDispatch _ = Nothing + +nodeReadModel :: Node -> Maybe ReadModelNode +nodeReadModel (NReadModel readModel) = Just readModel +nodeReadModel _ = Nothing + +nodeWorkflow :: Node -> Maybe WorkflowNode +nodeWorkflow (NWorkflow workflow) = Just workflow +nodeWorkflow _ = Nothing + +{- | Router identity is replay-sensitive: the stable name and key feed every +target-keyed dispatch id, and the target selects the persisted stream family. +-} +routerDiff :: DiffEnv -> [Change] +routerDiff env = + concatMap (uncurry routerPairDiff) (prMatched paired) + ++ [additive (rtId router) "router" (rtId router) "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 + where + nodeName = rtId newRouter + stableName = + [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $ + "router stable name changed from '" <> rtName oldRouter <> "' to '" <> rtName newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out" + | rtName oldRouter /= rtName newRouter + ] + keyDerivation = + [ breaking nodeName "router-key" (corrField (rtKey newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids" + | rtKey oldRouter /= rtKey newRouter + ] + target = + [ breaking nodeName "router-target" (rtTarget newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family" + | rtTarget oldRouter /= rtTarget newRouter + ] + +readModelDiff :: DiffEnv -> [Change] +readModelDiff env = + concatMap (uncurry (readModelPairDiff env)) (prMatched paired) + ++ concatMap addedReadModelDiff (prAdded paired) + ++ concatMap removedReadModelDiff (prRemoved paired) + where + paired = pairByName nodeReadModel rmName env + +readModelPairDiff :: DiffEnv -> ReadModelNode -> ReadModelNode -> [Change] +readModelPairDiff env oldReadModel newReadModel = + versionChanges + ++ shapeChanges + ++ identityChanges + ++ feedChanges + ++ consistencyChanges + ++ scopeChanges + where + nodeName = rmName newReadModel + versionChanges + | rmVersion newReadModel < rmVersion oldReadModel = + [ 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") + ] + | otherwise = [] + oldShape = (rmColumns oldReadModel, rmShape oldReadModel) + newShape = (rmColumns newReadModel, rmShape newReadModel) + shapeChanges = + [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt (rmVersion newReadModel) <> "; bump version and rebuild") + | oldShape /= newShape + , rmVersion oldReadModel == rmVersion newReadModel + ] + oldRegistry = registryNameFor (specContext (deOld env)) oldReadModel + newRegistry = registryNameFor (specContext (deNew env)) newReadModel + oldSubscription = subscriptionNameFor (specContext (deOld env)) oldReadModel + newSubscription = subscriptionNameFor (specContext (deNew env)) newReadModel + identityChanges = + [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned") + | oldRegistry /= newRegistry + ] + ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity") + | (rmSchema oldReadModel, rmTable oldReadModel) /= (rmSchema newReadModel, rmTable newReadModel) + ] + ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity") + | oldSubscription /= newSubscription + ] + feedChanges = + [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed (rmFeed oldReadModel) <> " -> " <> renderFeed (rmFeed newReadModel) <> "; projection wiring and rebuild identities changed") + | rmFeed oldReadModel /= rmFeed newReadModel + ] + consistencyChanges = case (rmConsistency oldReadModel, rmConsistency newReadModel) of + (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"] + _ -> [] + 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)] + | 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"] + +removedReadModelDiff :: ReadModelNode -> [Change] +removedReadModelDiff readModel = + [breaking (rmName readModel) "read-model-identity" (rmName readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"] + +qualifiedIdentity :: ReadModelNode -> Text +qualifiedIdentity readModel = rmSchema readModel <> "." <> rmTable readModel + +renderFeed :: RmFeed -> Text +renderFeed RmInline = "inline" +renderFeed RmSubscription = "subscription" + +effectiveScope :: Maybe RmScope -> RmScope +effectiveScope Nothing = RmEntireLog +effectiveScope (Just scope) = scope + +scopeStrengthened :: RmScope -> RmScope -> Bool +scopeStrengthened (RmCategory _) RmEntireLog = True +scopeStrengthened _ _ = False + +renderScope :: RmScope -> Text +renderScope RmEntireLog = "entire-log" +renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'" + +aggregateDiff :: DiffEnv -> [Change] +aggregateDiff env = + concatMap (uncurry aggregatePairDiff) (prMatched paired) + ++ concatMap addedAggregateDiff (prAdded paired) + ++ concatMap removedAggregateDiff (prRemoved paired) + where + paired = pairByName nodeAggregate aggName env + +aggregatePairDiff :: Aggregate -> Aggregate -> [Change] +aggregatePairDiff oldAgg newAgg = + concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg) + ++ removedEvents oldAgg newAgg + ++ wireDiff oldAgg newAgg + ++ projectionDiff oldAgg newAgg + +addedAggregateDiff :: Aggregate -> [Change] +addedAggregateDiff newAgg = + [ additive (aggName newAgg) "event" (evName e) "new event type (new aggregate)" + | e <- aggEvents newAgg + ] + +removedAggregateDiff :: Aggregate -> [Change] +removedAggregateDiff oldAgg = + [ breaking (aggName oldAgg) "event" (evName e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable" + | e <- aggEvents oldAgg + ] + +-- | Per-event classification for an event present in the new aggregate. +eventDiff :: Aggregate -> Aggregate -> Event -> [Change] +eventDiff oldAgg newAgg e = + case find ((== evName e) . evName) (aggEvents oldAgg) of + Nothing -> + [additive (aggName newAgg) "event" (evName e) "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))] + else + [ breaking + (aggName newAgg) + "event" + (evName e) + EvtVersionMissingUpcaster + ( "version changed from v" + <> tInt (evVersion oldE) + <> " to v" + <> tInt (evVersion e) + <> " without the required contiguous upcaster from v" + <> tInt (evVersion oldE) + ) + ] + | evVersion e < evVersion oldE -> + [breaking (aggName newAgg) "event" (evName e) EvtVersionDecreased ("version decreased from v" <> tInt (evVersion oldE) <> " to v" <> tInt (evVersion e))] + | otherwise -> + 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. +-} +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" + | oldE <- aggEvents oldAgg + , isNothing (find ((== evName oldE) . evName) (aggEvents newAgg)) + ] + +hasSource :: Maybe (Int, Hole) -> Int -> Bool +hasSource (Just (m, _)) n = m == n +hasSource Nothing _ = False + +eventFieldSigs :: Aggregate -> Event -> [(Name, Maybe Name)] +eventFieldSigs agg e = case evBody e of + EventFields fs -> map fieldSig fs + EventFromCommand cn -> + maybe [] (map fieldSig . cmdFields) (find ((== cn) . cmdName) (aggCommands agg)) + where + fieldSig f = (fieldName f, fieldType f) + +sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change] +sameVersionEventDiff oldAgg newAgg oldE newE = + addedChanges + ++ removedChanges + ++ typeChanges + ++ deprecationChanges + where + oldFields = eventFieldSigs oldAgg oldE + newFields = eventFieldSigs newAgg newE + oldNames = map fst oldFields + newNames = map fst newFields + added = newNames \\ oldNames + removed = oldNames \\ newNames + changed = + [ (field, oldType, newType) + | (field, oldType) <- oldFields + , Just newType <- [lookup field newFields] + , oldType /= newType + ] + addedChanges = + [ breaking (aggName newAgg) "event" (evName newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt (evVersion newE) <> " without a version bump or upcaster") + | not (null added) + ] + removedChanges = + [ breaking (aggName newAgg) "event" (evName newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt (evVersion newE)) + | not (null removed) + ] + typeChanges = + [ breaking + (aggName newAgg) + "event-field" + (evName newE <> "." <> field) + EvtFieldTypeChanged + ("type changed " <> renderFieldType oldType <> " -> " <> renderFieldType newType <> " at the same version v" <> tInt (evVersion newE)) + | (field, oldType, newType) <- changed + ] + deprecationChanges + | not (evDeprecated oldE) && evDeprecated newE = + [additive (aggName newAgg) "event" (evName newE) "event deprecated (still decodable)"] + | evDeprecated oldE && not (evDeprecated newE) = + [advisory (aggName newAgg) "event" (evName newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"] + | otherwise = [] + +renderFieldType :: Maybe Name -> Text +renderFieldType Nothing = "(declared)" +renderFieldType (Just name) = name + +wireDiff :: Aggregate -> Aggregate -> [Change] +wireDiff oldAgg newAgg + | effectiveWire (aggWire oldAgg) == effectiveWire (aggWire newAgg) = [] + | otherwise = + [ breaking + (aggName newAgg) + "wire" + (aggName newAgg) + WireSpecChanged + ("effective wire convention changed " <> renderWire (effectiveWire (aggWire oldAgg)) <> " -> " <> renderWire (effectiveWire (aggWire newAgg))) + ] + +effectiveWire :: Maybe WireSpec -> (Text, Text) +effectiveWire Nothing = ("ctorName", "camelCase") +effectiveWire (Just w) = (wireKind w, wireFields w) + +renderWire :: (Text, Text) -> Text +renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames + +projectionDiff :: Aggregate -> Aggregate -> [Change] +projectionDiff oldAggregate newAggregate + | projectionSurface (aggProjection oldAggregate) == projectionSurface (aggProjection newAggregate) = [] + | otherwise = + [ advisory + (aggName newAggregate) + "projection" + (aggName newAggregate) + ProjectionChanged + "projection table, consistency, key, or status mapping changed; coordinate the read-model migration" + ] + +projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping) +projectionSurface projection = do + value <- projection + pure (projTable value, projConsistency value, projKey value, projStatusMap value) + +idDiff :: DiffEnv -> [Change] +idDiff env = + concatMap (uncurry idPairDiff) (prMatched paired) + ++ concatMap addedIdDiff (prAdded paired) + ++ concatMap removedIdDiff (prRemoved paired) + where + paired = pairDeclarations idName (specIds (deOld env)) (specIds (deNew env)) + +idPairDiff :: IdDecl -> IdDecl -> [Change] +idPairDiff oldId newId = + [ breaking (idName newId) "id-prefix" (idName newId) IdPrefixChanged ("prefix changed '" <> idPrefix oldId <> "' -> '" <> idPrefix newId <> "'; stored and newly minted ids no longer share an identity domain") + | idPrefix oldId /= idPrefix newId + ] + +addedIdDiff :: IdDecl -> [Change] +addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) "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"] + +enumDiff :: DiffEnv -> [Change] +enumDiff env = + concatMap (uncurry (enumPairDiff (deOld env))) (prMatched paired) + ++ concatMap addedEnumDiff (prAdded paired) + ++ concatMap (removedEnumDiff (deOld env)) (prRemoved paired) + where + paired = pairDeclarations enumName (specEnums (deOld env)) (specEnums (deNew env)) + +enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change] +enumPairDiff oldSpec oldEnum newEnum = + [ breaking (enumName newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName oldEnum)) + | (ctor, wire) <- enumCtors oldEnum + , isNothing (lookup ctor (enumCtors newEnum)) + ] + ++ [ breaking (enumName newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec (enumName oldEnum)) + | (ctor, oldWire) <- enumCtors oldEnum + , 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)) + ] + +addedEnumDiff :: EnumDecl -> [Change] +addedEnumDiff enumDecl = + [additive (enumName enumDecl) "enum-constructor" ctor ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl] + +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)) + | (ctor, wire) <- enumCtors enumDecl + ] + +enumUsageSuffix :: Spec -> Name -> Text +enumUsageSuffix spec enumType = case enumUsages spec enumType of + [] -> "" + usages -> "; used by " <> commas usages + +enumUsages :: Spec -> Name -> [Text] +enumUsages spec enumType = + [aggName agg <> ".reg." <> regName reg | agg <- aggregates, reg <- aggRegs agg, regType reg == enumType] + ++ [ aggName agg <> ".event." <> evName event <> "." <> field + | agg <- aggregates + , event <- aggEvents agg + , (field, Just fieldTypeName) <- eventFieldSigs agg event + , fieldTypeName == enumType + ] + where + aggregates = [agg | NAggregate agg <- specNodes spec] + +pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n +pairDeclarations nameOf oldNodes newNodes = + Paired + { prMatched = + [ (oldNode, newNode) + | newNode <- newNodes + , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes] + ] + , prAdded = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)] + , prRemoved = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)] + } + +contractDiff :: DiffEnv -> [Change] +contractDiff env = + concatMap (uncurry contractPairDiff) (prMatched paired) + ++ concatMap addedContractDiff (prAdded paired) + ++ concatMap removedContractDiff (prRemoved paired) + where + paired = pairByName nodeContract ctrName env + +contractPairDiff :: ContractNode -> ContractNode -> [Change] +contractPairDiff oldContract newContract = + schemaChanges + ++ discriminatorChanges + ++ topicChanges + ++ concatMap eventPairChanges matchedEvents + ++ concatMap addedEventChanges addedEvents + ++ concatMap removedEventChanges removedEvents' + where + schemaChanges = + [ breaking + (ctrName newContract) + "schema-version" + (ctrName newContract) + ContractSchemaVersionDecreased + ("schemaVersion decreased from " <> tInt (ctrSchemaVersion oldContract) <> " to " <> tInt (ctrSchemaVersion newContract)) + | ctrSchemaVersion newContract < ctrSchemaVersion oldContract + ] + discriminatorChanges = + [ breaking + (ctrName newContract) + "discriminator" + (ctrName newContract) + ContractDiscriminatorChanged + ("discriminator changed " <> ctrDiscriminator oldContract <> " -> " <> ctrDiscriminator newContract) + | ctrDiscriminator oldContract /= ctrDiscriminator newContract + ] + topicChanges = contractTopicDiff oldContract newContract + eventPairs = pairDeclarations ceName (ctrEvents oldContract) (ctrEvents newContract) + matchedEvents = prMatched eventPairs + addedEvents = prAdded eventPairs + removedEvents' = prRemoved eventPairs + eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent + addedEventChanges event = + [additive (ctrName newContract) "contract-event" (ceName event) "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] + +removedContractDiff :: ContractNode -> [Change] +removedContractDiff contract = + [breaking (ctrName contract) "contract-event" (ceName event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- ctrEvents contract] + +contractTopicDiff :: ContractNode -> ContractNode -> [Change] +contractTopicDiff oldContract newContract = + [ breaking + (ctrName newContract) + "contract-topic" + alias + ContractTopicChanged + ("topic alias removed; previous topic was '" <> oldTopic <> "'") + | (alias, oldTopic) <- ctrTopics oldContract + , isNothing (lookup alias (ctrTopics newContract)) + ] + ++ [ breaking + (ctrName newContract) + "contract-topic" + alias + ContractTopicChanged + ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'") + | (alias, oldTopic) <- ctrTopics oldContract + , Just newTopic <- [lookup alias (ctrTopics newContract)] + , oldTopic /= newTopic + ] + ++ [ additive (ctrName newContract) "contract-topic" alias ("new topic alias for '" <> topic <> "'") + | (alias, topic) <- ctrTopics newContract + , isNothing (lookup alias (ctrTopics oldContract)) + ] + +contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change] +contractEventDiff oldContract newContract oldEvent newEvent = + topicAliasChange + ++ removedFieldChanges + ++ changedFieldChanges + ++ addedFieldChanges + where + fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent) + topicAliasChange = + [ breaking + (ctrName newContract) + "contract-topic" + (ceName newEvent) + ContractTopicChanged + ("event topic alias changed " <> ceTopic oldEvent <> " -> " <> ceTopic newEvent) + | ceTopic oldEvent /= ceTopic newEvent + ] + removedFieldChanges = + [ breaking (ctrName newContract) "contract-field" (ceName newEvent <> "." <> cfName field) ContractFieldChanged "field removed; existing messages still carry the old contract shape" + | field <- prRemoved fieldPairs + ] + changedFieldChanges = + [ breaking + (ctrName newContract) + "contract-field" + (ceName newEvent <> "." <> cfName newField) + ContractFieldChanged + ("field type changed " <> renderContractType (cfType oldField) <> " -> " <> renderContractType (cfType newField)) + | (oldField, newField) <- prMatched fieldPairs + , cfType oldField /= cfType newField + ] + addedFieldChanges = + [ if ctrSchemaVersion newContract > ctrSchemaVersion oldContract + then advisory (ctrName newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt (ctrSchemaVersion oldContract) <> " -> " <> tInt (ctrSchemaVersion newContract) <> "; coordinate the cross-service rollout") + else breaking (ctrName newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it" + | field <- prAdded fieldPairs + , let subject = ceName newEvent <> "." <> cfName field + ] + +renderContractType :: ContractType -> Text +renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'" +renderContractType CText = "text" +renderContractType CInt = "int" + +workqueueDiff :: DiffEnv -> [Change] +workqueueDiff env = + concatMap (uncurry workqueuePairDiff) (prMatched paired) + ++ concatMap addedWorkqueueDiff (prAdded paired) + ++ concatMap removedWorkqueueDiff (prRemoved paired) + where + paired = pairByName nodeWorkqueue wqName env + +workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change] +workqueuePairDiff oldQueue newQueue = + concatMap pairedFieldDiff (prMatched fields) + ++ concatMap addedFieldDiff (prAdded fields) + ++ concatMap removedFieldDiff (prRemoved fields) + ++ queueIdentityDiff oldQueue newQueue + ++ queuePolicyDiff oldQueue newQueue + where + -- wqPayloadName is a generated Haskell type name, not a wire-visible name. + fields = pairDeclarations wqfName (wqPayload oldQueue) (wqPayload newQueue) + pairedFieldDiff (oldField, newField) + | 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"] + | 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"] + 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] + +removedWorkqueueDiff :: WorkqueueNode -> [Change] +removedWorkqueueDiff queue = + [breaking (wqName queue) "payload-field" (wqfName field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- wqPayload queue] + ++ [breaking (wqName queue) "queue-identity" (wqName queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"] + +queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change] +queueIdentityDiff oldQueue newQueue = + [ breaking + (wqName newQueue) + "queue-identity" + (wqName newQueue) + QueueIdentityChanged + "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity" + | queueIdentity oldQueue /= queueIdentity newQueue + ] + +queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text) +queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue) + +queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change] +queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey + where + nodeName = wqName newQueue + ordering = + [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $ + "ordering changed " <> renderWqOrdering (wqOrdering oldQueue) <> " -> " <> renderWqOrdering (wqOrdering newQueue) <> "; consumers were written against the old delivery-order contract" + | wqOrdering oldQueue /= wqOrdering newQueue + ] + provision = + [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $ + "provision changed " <> renderWqProvision (wqProvision oldQueue) <> " -> " <> renderWqProvision (wqProvision newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec" + | wqProvision oldQueue /= wqProvision newQueue + ] + groupKey = + [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $ + "group key derivation changed " <> renderWqGroupKey (wqGroupKey oldQueue) <> " -> " <> renderWqGroupKey (wqGroupKey newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups" + | wqGroupKey oldQueue /= wqGroupKey newQueue + ] + +renderWqOrdering :: WqOrdering -> Text +renderWqOrdering WqUnordered = "unordered" +renderWqOrdering WqFifoThroughput = "fifo-throughput" +renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin" + +renderWqProvision :: WqProvision -> Text +renderWqProvision WqStandard = "standard" +renderWqProvision WqUnlogged = "unlogged" +renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")" + +renderWqGroupKey :: Maybe WqGroupKey -> Text +renderWqGroupKey Nothing = "none" +renderWqGroupKey (Just groupKey) = + gkField groupKey + <> " via " + <> gkVia groupKey + <> maybe "" (" fixture " <>) (gkFixture groupKey) + +processDiff :: DiffEnv -> [Change] +processDiff env = + concatMap (uncurry processPairDiff) (prMatched paired) + ++ concatMap addedProcessDiff (prAdded paired) + ++ concatMap removedProcessDiff (prRemoved paired) + where + paired = pairByName nodeProcess procId env + +processPairDiff :: ProcessNode -> ProcessNode -> [Change] +processPairDiff oldProcess newProcess = + concatMap pairedFieldDiff (prMatched fields) + ++ map (fieldChange "field added; source events at the old shape cannot populate it") (prAdded fields) + ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields) + ++ processIdentityDiff oldProcess newProcess + ++ processTimerWindowDiff oldProcess newProcess + where + -- inName is a generated Haskell type name; the wire shape is inFields. + fields = pairDeclarations fieldName (inFields (procInput oldProcess)) (inFields (procInput newProcess)) + pairedFieldDiff (oldField, newField) + | fieldType oldField /= fieldType newField = [fieldChange ("type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) newField] + | otherwise = [] + fieldChange detail field = breaking (procId newProcess) "input-field" (fieldName field) ProcessInputChanged (detail <> "; version the source event before changing process input") + +addedProcessDiff :: ProcessNode -> [Change] +addedProcessDiff process = + [additive (procId process) "input-field" (fieldName field) "field belongs to a new process input" | field <- inFields (procInput process)] + +removedProcessDiff :: ProcessNode -> [Change] +removedProcessDiff process = + [breaking (procId process) "input-field" (fieldName field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- inFields (procInput process)] + ++ [breaking (procId process) "derived-identity" (procId process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"] + +processIdentityDiff :: ProcessNode -> ProcessNode -> [Change] +processIdentityDiff oldProcess newProcess = + [ breaking + (procId newProcess) + "derived-identity" + (procId newProcess) + DerivedIdentityChanged + "process name, correlation derivation, saga stream category, timer id prefix, or fired-event-id prefix changed; replays and retries no longer derive the persisted identity" + | processIdentity oldProcess /= processIdentity newProcess + ] + +processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Text) +processIdentity process = + ( procName process + , corrField (procCorrelate process) + , corrVia (procCorrelate process) + , sagaCategory (procSaga process) + , idePrefix (tmId (procTimer process)) + , idePrefix (fireFiredEventId (tmFire (procTimer process))) + ) + +processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change] +processTimerWindowDiff oldProcess newProcess = + [ advisory + (procId newProcess) + "timer" + (tmName (procTimer newProcess)) + TimerWindowChanged + ( "fireAt source/window changed " + <> renderFireAt (tmFireAt (procTimer oldProcess)) + <> " -> " + <> renderFireAt (tmFireAt (procTimer newProcess)) + <> "; already-scheduled timers keep their persisted deadline" + ) + | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess) + ] + +renderFireAt :: FireAtExpr -> Text +renderFireAt expression = "input." <> faField expression <> " + " <> faWindow expression + +workflowDiff :: DiffEnv -> [Change] +workflowDiff env = + concatMap (uncurry workflowPairDiff) (prMatched paired) + ++ concatMap addedWorkflowDiff (prAdded paired) + ++ concatMap removedWorkflowDiff (prRemoved paired) + where + paired = pairByName nodeWorkflow wfId env + +workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change] +workflowPairDiff oldWorkflow newWorkflow = + inputChanges + ++ outputChanges + ++ classifyWorkflowBody oldWorkflow newWorkflow + ++ workflowIdentityDiff oldWorkflow newWorkflow + where + fields = pairDeclarations fieldName (wfInputFields oldWorkflow) (wfInputFields newWorkflow) + inputChanges = + [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- prAdded fields] + ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- prRemoved fields] + ++ [ workflowShape newField ("input field type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) + | (oldField, newField) <- prMatched fields + , fieldType oldField /= fieldType newField + ] + outputChanges = + [ breaking (wfId newWorkflow) "workflow-output" (wfOutput newWorkflow) WorkflowShapeChanged ("output type changed " <> wfOutput oldWorkflow <> " -> " <> wfOutput newWorkflow <> "; persisted outcomes may no longer decode") + | wfOutput oldWorkflow /= wfOutput newWorkflow + ] + 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"] + +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"] + +workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change] +workflowIdentityDiff oldWorkflow newWorkflow = + [ breaking + (wfId newWorkflow) + "workflow-name" + (wfId newWorkflow) + WorkflowStableNameChanged + ("stable name changed '" <> wfStable oldWorkflow <> "' -> '" <> wfStable newWorkflow <> "'; in-flight journals remain under the old stream name") + | wfStable oldWorkflow /= wfStable newWorkflow + ] + ++ [ breaking + (wfId newWorkflow) + "derived-identity" + (wfId newWorkflow) + DerivedIdentityChanged + "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions" + | (wfIdField oldWorkflow, wfIdVia oldWorkflow) /= (wfIdField newWorkflow, wfIdVia newWorkflow) + ] + +intakeDiff :: DiffEnv -> [Change] +intakeDiff env = + concatMap (uncurry intakePairDiff) (prMatched paired) + ++ concatMap addedIntakeDiff (prAdded paired) + ++ concatMap removedIntakeDiff (prRemoved paired) + where + paired = pairByName nodeIntake inkName env + +intakePairDiff :: IntakeNode -> IntakeNode -> [Change] +intakePairDiff oldIntake newIntake = + [ breaking + (inkName newIntake) + "dedupe-identity" + (inkName newIntake) + DedupeIdentityChanged + "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record" + | (inkDedupeKey oldIntake, inkDedupePolicy oldIntake) /= (inkDedupeKey newIntake, inkDedupePolicy newIntake) + ] + ++ [ advisory + (inkName newIntake) + "decode-posture" + (inkName newIntake) + DecodePostureChanged + "envelope/body decode posture changed; future messages are accepted or rejected differently" + | inkDecode oldIntake /= inkDecode newIntake + ] + ++ [ advisory + (inkName newIntake) + "inbox-persistence" + (inkName newIntake) + IntakePersistenceChanged + ("success-path envelope persistence changed " <> renderInkPersist (inkPersist oldIntake) <> " -> " <> renderInkPersist (inkPersist newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape") + | inkPersist oldIntake /= inkPersist newIntake + ] + +renderInkPersist :: InkPersist -> Text +renderInkPersist InkPersistFull = "full-envelope" +renderInkPersist InkPersistDedupeOnly = "dedupe-only" + +addedIntakeDiff :: IntakeNode -> [Change] +addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) "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"] + +emitDiff :: DiffEnv -> [Change] +emitDiff env = + concatMap (uncurry emitPairDiff) (prMatched paired) + ++ concatMap addedEmitDiff (prAdded paired) + ++ concatMap removedEmitDiff (prRemoved paired) + where + paired = pairByName nodeEmit emName env + +emitPairDiff :: EmitNode -> EmitNode -> [Change] +emitPairDiff oldEmit newEmit = + [ breaking + (emName newEmit) + "derived-identity" + "messageId" + DerivedIdentityChanged + "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages" + | emMessageId oldEmit /= emMessageId newEmit + ] + ++ [ breaking + (emName newEmit) + "derived-identity" + "idempotencyKey" + DerivedIdentityChanged + "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages" + | emIdempotencyKey oldEmit /= emIdempotencyKey newEmit + ] + ++ [ advisory + (emName newEmit) + "emit-mapping" + (emName newEmit) + EmitMappingChanged + "emit key, status discriminant, mapping rows, or explicit skip posture changed" + | emitMapping oldEmit /= emitMapping newEmit + ] + +emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool) +emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit) + +addedEmitDiff :: EmitNode -> [Change] +addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) "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"] + +publisherDiff :: DiffEnv -> [Change] +publisherDiff env = + concatMap (uncurry publisherPairDiff) (prMatched paired) + ++ concatMap addedPublisherDiff (prAdded paired) + ++ concatMap removedPublisherDiff (prRemoved paired) + where + paired = pairByName nodePublisher pubName env + +publisherPairDiff :: PublisherNode -> PublisherNode -> [Change] +publisherPairDiff oldPublisher newPublisher = + -- maxAttempts/backoff are retry tuning, not persisted decode or identity. + [ breaking + (pubName newPublisher) + "derived-identity" + "outboxId" + DerivedIdentityChanged + "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows" + | pubOutboxField oldPublisher /= pubOutboxField newPublisher + ] + ++ [ advisory + (pubName newPublisher) + "publisher-policy" + (pubName newPublisher) + PublisherPolicyChanged + ("ordering changed " <> pubOrdering oldPublisher <> " -> " <> pubOrdering newPublisher) + | pubOrdering oldPublisher /= pubOrdering newPublisher + ] + +addedPublisherDiff :: PublisherNode -> [Change] +addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) "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"] + +pgmqDispatchDiff :: DiffEnv -> [Change] +pgmqDispatchDiff env = + concatMap (uncurry pgmqDispatchPairDiff) (prMatched paired) + ++ concatMap addedPgmqDispatchDiff (prAdded paired) + ++ concatMap removedPgmqDispatchDiff (prRemoved paired) + where + paired = pairByName nodePgmqDispatch pdName env + +pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change] +pgmqDispatchPairDiff oldDispatch newDispatch = + [ breaking + (pdName newDispatch) + "dedupe-identity" + (pdName newDispatch) + DedupeIdentityChanged + "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match" + | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch + ] + ++ [ advisory + (pdName newDispatch) + "retarget" + (pdName newDispatch) + DispatchRetargeted + "source read model or target queue changed; future fan-out is routed differently" + | dispatchTargets oldDispatch /= dispatchTargets newDispatch + ] + +dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text) +dispatchDedupe dispatch = + ( pdDedupKey dispatch + , pdDedupReadModel dispatch + , pdDedupReadModelField dispatch + , pdDedupQueue dispatch + , pdDedupQueueField dispatch + ) + +dispatchTargets :: PgmqDispatchNode -> (Name, Name) +dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch) + +addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change] +addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) "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"] + +{- | Classify the runtime's sanctioned workflow-evolution mechanisms before +falling back to the conservative unguarded-body rule. +-} +classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change] +classifyWorkflowBody oldWorkflow newWorkflow + | oldBody == newBody = [] + | not (null removedPatchIds) = map removedPatch removedPatchIds + | Just (oldSeedType, newSeedType) <- changedSeed = + [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $ + "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation" + ] + | safeAdditions = + map addedPatch newPatchIds + ++ [ additive nodeName "workflow-continue-as-new" seedType "terminal continueAsNew is additive; old generations carry no rotation marker" + | Just seedType <- [appendedSeed] + ] + | otherwise = + [ breaking + nodeName + "workflow-body" + nodeName + WorkflowBodyChanged + "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step" + ] + where + nodeName = wfId newWorkflow + oldBody = normaliseWorkflowBody (wfBody oldWorkflow) + newBody = normaliseWorkflowBody (wfBody newWorkflow) + oldPatchIds = workflowBodyPatchIds oldBody + newPatchIdsAll = workflowBodyPatchIds newBody + newPatchIds = newPatchIdsAll \\ oldPatchIds + removedPatchIds = oldPatchIds \\ newPatchIdsAll + oldSeed = terminalContinueSeed oldBody + newSeed = terminalContinueSeed newBody + changedSeed = case (oldSeed, newSeed) of + (Just oldSeedType, Just newSeedType) + | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType) + _ -> Nothing + appendedSeed = case (oldSeed, newSeed) of + (Nothing, Just seedType) -> Just seedType + _ -> Nothing + strippedNewBody = stripNewPatches newPatchIds newBody + comparableNewBody = case appendedSeed of + Just _ -> dropTerminalContinue strippedNewBody + Nothing -> strippedNewBody + safeAdditions = + (not (null newPatchIds) || isJust appendedSeed) + && comparableNewBody == oldBody + 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" + +normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem] +normaliseWorkflowBody = map go + where + go (WfStep label result _) = WfStep label result noLoc + go (WfAwait label result _) = WfAwait label result noLoc + go (WfSleep label delay _) = WfSleep label delay noLoc + go (WfChild label via result _) = WfChild label via result noLoc + go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc + go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc + +workflowBodyPatchIds :: [WfBodyItem] -> [Name] +workflowBodyPatchIds = concatMap go + where + go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items + go _ = [] + +stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem] +stripNewPatches newPatchIds = concatMap go + where + go (WfPatch patchId _ _) | patchId `elem` newPatchIds = [] + go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc] + go item = [item] + +terminalContinueSeed :: [WfBodyItem] -> Maybe Name +terminalContinueSeed items = case reverse items of + WfContinueAsNew seedType _ : _ -> Just seedType + _ -> Nothing + +dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem] +dropTerminalContinue items = case reverse items of + WfContinueAsNew{} : rest -> reverse rest + _ -> items + +additive :: Name -> Text -> Text -> Text -> Change +additive n facet subj detail = Additive (ChangeKind n facet subj Nothing detail) + +breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change +breaking n facet subj c detail = Breaking (ChangeKind n facet subj (Just c) detail) + +advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change +advisory n facet subj c detail = Advisory (ChangeKind n facet subj (Just c) detail) + +commas :: [Text] -> Text +commas = T.intercalate ", " + +tInt :: Int -> Text +tInt = T.pack . show diff --git a/src/Keiro/Dsl/Grammar.hs b/src/Keiro/Dsl/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Grammar.hs @@ -0,0 +1,997 @@ +{- | The abstract syntax of the keiro DSL (@.keiro@) — the shared engine type that +every later vertical (EP-2…EP-6) extends additively. EP-1 defines the shared +declarations, the 'Expr' sublanguage, the eight hole-kind types, and the +'Aggregate' node. New node families add a 'Node' constructor here in lockstep +with their parser, validator, and scaffold cases. +-} +module Keiro.Dsl.Grammar ( + -- * Names and source locations + Name, + Loc (..), + noLoc, + + -- * Shared declarations + IdDecl (..), + EnumDecl (..), + RuleDecl (..), + + -- * The eight hole-kind types + Derivation (..), + DerivStrategy (..), + Disposition (..), + DispAction (..), + Mapping (..), + EnvelopeBinding (..), + EnvelopeLayer (..), + + -- * The Expr sublanguage + Expr (..), + CmpOp (..), + Atom (..), + + -- * The aggregate node + RegInitial (..), + RegDecl (..), + StateDecl (..), + Field (..), + Command (..), + Event (..), + EventBody (..), + Hole (..), + Transition (..), + WireSpec (..), + ProjectionSpec (..), + Consistency (..), + SnapPolicy (..), + SnapshotSpec (..), + Aggregate (..), + + -- * The process + timer nodes (EP-3) + FieldBinding (..), + InputDecl (..), + CorrelateDecl (..), + SagaRef (..), + Disp (..), + DispatchDisposition (..), + AdvanceNode (..), + DispatchNode (..), + HandleNode (..), + IdExpr (..), + IdStrategy (..), + FireAtExpr (..), + FireOutcome (..), + FireDisposition (..), + FireNode (..), + TimerNode (..), + PolicyChoice (..), + ProcessNode (..), + + -- * The router node (EP-108) + ResolveSource (..), + ResolveDecl (..), + RouterDispatchNode (..), + RouterNode (..), + + -- * The integration contract node (EP-4) + ContractType (..), + ContractField (..), + ContractEvent (..), + ContractNode (..), + + -- * The integration intake (inbox) node (EP-4) + WireSource (..), + BindRow (..), + InboxAction (..), + DispositionRow (..), + DecodeSpec (..), + InkPersist (..), + IntakeNode (..), + + -- * The integration emit/publisher nodes (EP-4) + DeriveSpec (..), + EmitMapRow (..), + EmitNode (..), + BackoffSpec (..), + PublisherNode (..), + + -- * The pgmq workqueue/dispatch nodes (EP-5) + WqField (..), + WqDispRow (..), + WqOrdering (..), + WqGroupKey (..), + WqProvision (..), + WorkqueueNode (..), + PgmqDispatchNode (..), + + -- * Read-model nodes (EP-107) + RmColumn (..), + RmFeed (..), + RmScope (..), + ReadModelNode (..), + + -- * The workflow/operation nodes (EP-6) + WfBodyItem (..), + WorkflowNode (..), + OperationShape (..), + OperationNode (..), + + -- * Top level + Placement (..), + Node (..), + Spec (..), +) +where + +import Data.Text (Text) +import GHC.Generics (Generic) + +{- | An identifier in the notation: a type name, register name, command/event +name, state name, enum constructor, etc. Always a non-empty 'Text'. +-} +type Name = Text + +{- | A source line number, attached to declarations so the validator can emit +line-numbered diagnostics. Its 'Eq' instance deliberately ignores the line +value: two ASTs that differ only in source position are considered equal, so +the @parse . pretty == id@ round-trip property holds without the +pretty-printer having to reproduce exact line numbers. +-} +newtype Loc = Loc {unLoc :: Int} + deriving stock (Show) + +instance Eq Loc where + _ == _ = True + +-- | A placeholder location used by generators and pretty-print round-trips. +noLoc :: Loc +noLoc = Loc 0 + +{- | @id TransferReservationId prefix=rsv@ — declares an id newtype over 'Text' +and its prefix tag. +-} +data IdDecl = IdDecl + { idName :: !Name + , idPrefix :: !Text + , idLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | @enum PatientAcuity { RedTag=red … }@ — a closed enumeration; each +constructor carries its wire spelling (the right-hand side of @=@). +-} +data EnumDecl = EnumDecl + { enumName :: !Name + , enumCtors :: ![(Name, Text)] + , enumLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | @rule lifeCriticalOverride : PatientAcuity -> Bool@ with an @ex@ line of +@Ctor => bool ; …@ — a total function from an enum to a value, used as a +derived atom inside guards. +-} +data RuleDecl = RuleDecl + { ruleName :: !Name + , ruleDomain :: !Name + , ruleCodomain :: !Name + , ruleCases :: ![(Name, Expr)] + , ruleLoc :: !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. + +{- | Hole-kind 1: a deterministic id/string derivation. Opaque strategies must +carry a captured @fixture@ (not a prose rule) so two agents re-derive them +identically. +-} +data Derivation = Derivation + { derivStrategy :: !DerivStrategy + , derivFixture :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +data DerivStrategy = UuidV5 | SuffixSplice + deriving stock (Eq, Show, Generic) + +{- | Hole-kind 2: a failure→action table. Carries the two dangerous inversions a +@duplicate@/@rejected replay@ being treated as success and a +@previously-failed@ being dead-lettered rather than retried (enforced by +EP-4's validator rules). +-} +newtype Disposition = Disposition + { dispCases :: [(Name, DispAction)] + } + deriving stock (Eq, Show, Generic) + +data DispAction = AckOk | Retry !Int | DeadLetter !Text + deriving stock (Eq, Show, Generic) + +{- | Hole-kind 3: an explicit value→value table that is not an identity echo +(e.g. an event name → projection status). @mapPartial@ records whether the +spec author explicitly marked the table partial over its domain. +-} +data Mapping = Mapping + { mapPairs :: ![(Name, Name)] + , mapPartial :: !Bool + } + deriving stock (Eq, Show, Generic) + +{- | Hole-kind 4: which layer carries each envelope field, and whether the two +are cross-checked. Defined here for reuse; exercised by EP-4. +-} +data EnvelopeBinding = EnvelopeBinding + { envField :: !Name + , envLayer :: !EnvelopeLayer + , envCrossChecked :: !Bool + } + deriving stock (Eq, Show, Generic) + +data EnvelopeLayer = KafkaHeader | JsonBody + deriving stock (Eq, Show, Generic) + +{- | The @Expr@ sublanguage used by @guard@ clauses and the right-hand side of +@write@ clauses. An infix expression over 'Atom's; operators in precedence +order are @||@ (lowest), @&&@, then the relational comparisons. +-} +data Expr + = EOr !Expr !Expr + | EAnd !Expr !Expr + | ECmp !CmpOp !Expr !Expr + | EAtom !Atom + deriving stock (Eq, Show, Generic) + +data CmpOp = OpEq | OpNeq | OpLt | OpLe | OpGt | OpGe + deriving stock (Eq, Show, Generic) + +{- | An atom is either a bare boolean literal (@true@/@false@) or a name. Names +are kept syntactically neutral: at parse time an identifier is +indistinguishable between a register, a command field, an enum constructor, +and a rule, so the validator's scope-check (M2) resolves which one each +'AName' is against the declared sets. This keeps the parser honest and the +round-trip exact. +-} +data Atom + = AName !Name + | ABool !Bool + deriving stock (Eq, Show, Generic) + +{- | @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). +-} +data RegInitial + = RegInitBare !Text + | RegInitText !Text + deriving stock (Eq, Show, Generic) + +data RegDecl = RegDecl + { regName :: !Name + , regType :: !Name + , regInitial :: !RegInitial + , regLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | One entry in a @states@ list. @stTerminal@ is set when the name carries a +trailing @!@ (no outgoing transitions allowed). The first 'StateDecl' in an +aggregate's list is its initial state. +-} +data StateDecl = StateDecl + { stName :: !Name + , stTerminal :: !Bool + , stLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | A command/event field. A bare name (@fieldType = Nothing@) reuses the +field's declared type elsewhere; @name:Type@ gives an explicit type. +-} +data Field = Field + { fieldName :: !Name + , fieldType :: !(Maybe Name) + } + deriving stock (Eq, Show, Generic) + +-- | @command Name { field … }@ — a command constructor. +data Command = Command + { cmdName :: !Name + , cmdFields :: ![Field] + , cmdLoc :: !Loc + } + 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. +-} +data Event = Event + { evName :: !Name + , evBody :: !EventBody + , evVersion :: !Int + -- ^ The schema version of this event shape. Default 1; written @vN@ for N>1. + , evUpcastFrom :: !(Maybe (Int, Hole)) + {- ^ The source version this shape migrates /from/, paired with the upcaster + hole. @Just (n-1, …)@ for a @vN@ shape; 'Nothing' for v1. + -} + , evDeprecated :: !Bool + {- ^ Retired from the write path (no transition may @emit@ it) but still + decodable from the log. + -} + , evLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data EventBody + = EventFields ![Field] + | EventFromCommand !Name + deriving stock (Eq, Show, Generic) + +{- | A spec hole: an unfilled placeholder ('Hole', written @HOLE@ in the +notation) or a value the author supplied inline ('Filled'). +-} +data Hole = Hole | Filled !Text + deriving stock (Eq, Show, Generic) + +{- | A transition @Src -- Command --> clauses@. Clauses may be written +indentation-stacked or @;@-separated on one line. +-} +data Transition = Transition + { tSource :: !Name + , tCommand :: !Name + , tGuard :: !(Maybe Expr) + , tWrites :: ![(Name, Expr)] + , tEmits :: ![Name] + , tGoto :: !Name + , tLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | @wire kind=ctorName fields=camelCase schemaVersion=1@ — how events +serialize. +-} +data WireSpec = WireSpec + { wireKind :: !Text + , wireFields :: !Text + , wireSchemaVersion :: !Int + } + deriving stock (Eq, Show, Generic) + +{- | @projection table consistency=… key=… status-map { … }@ — the read-model +projection and its event→status 'Mapping' (hole-kind 3). +-} +data ProjectionSpec = ProjectionSpec + { projTable :: !Name + , projConsistency :: !(Maybe Consistency) + , projKey :: !Name + , projStatusMap :: !(Maybe Mapping) + , projLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data Consistency = Strong | Eventual + deriving stock (Eq, Show, Generic) + +-- | A generated aggregate snapshot policy supported by the notation. +data SnapPolicy = SnapEvery !Int | SnapOnTerminal + deriving stock (Eq, Show, Generic) + +-- | Snapshot policy plus the captured live state-codec identity. +data SnapshotSpec = SnapshotSpec + { snapPolicy :: !SnapPolicy + , snapCodecVersion :: !Int + , snapShapeHash :: !Text + , snapLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | An @aggregate@ node: a consistency boundary whose state is rebuilt by +replaying events. +-} +data Aggregate = Aggregate + { aggName :: !Name + , aggRegs :: ![RegDecl] + , aggStates :: ![StateDecl] + , aggCommands :: ![Command] + , aggEvents :: ![Event] + , aggTransitions :: ![Transition] + , aggWire :: !(Maybe WireSpec) + , aggProjection :: !(Maybe ProjectionSpec) + , aggSnapshot :: !(Maybe SnapshotSpec) + , aggLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-3: process manager + durable timer nodes. + +{- | A @field@ or @field=value@ binding inside a command\/payload field list. +A bare field reuses the input field of the same name; @name=value@ binds it to +an expression (kept as raw text, e.g. @timerId=timer.id@). +-} +data FieldBinding = FieldBinding + { fbName :: !Name + , fbValue :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +{- | @input SurgeInput { hospitalId … observedAt:Time }@ — the process's incoming +event shape (one field must be a @:Time@ field used by the timer deadline). +-} +data InputDecl = InputDecl + { inName :: !Name + , inFields :: ![Field] + } + deriving stock (Eq, Show, Generic) + +{- | @correlate input.hospitalId via idText@ — the correlation key (hole-kind 1 +derivation + hole-kind 4 field-source). +-} +data CorrelateDecl = CorrelateDecl + { corrField :: !Name + , corrVia :: !Name + } + deriving stock (Eq, Show, Generic) + +{- | @saga Surge category \"hospitalSurge\"@ — the saga's own aggregate plus +the validated stream category used with @Keiro.Stream.entityStream@. For a +correlation id @c@, the saga stream is @-@. +-} +data SagaRef = SagaRef + { sagaAgg :: !Name + , sagaCategory :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | A command dispatch outcome action. +data Disp = DAckOk | DRetry | DDeadLetter !Text + deriving stock (Eq, Show, Generic) + +{- | The complete dispatch disposition table (every arm mandatory; the +@on-duplicate AckOk@ benign inversion is explicit). Named to avoid clashing +with the hole-kind 'Disposition'. +-} +data DispatchDisposition = DispatchDisposition + { onAppended :: !Disp + , onDuplicate :: !Disp + , onFailed :: !Disp + } + deriving stock (Eq, Show, Generic) + +-- | @advance NoteSurgeThreshold { … }@ — the self-command that advances the saga. +data AdvanceNode = AdvanceNode + { advCommand :: !Name + , advFields :: ![FieldBinding] + } + deriving stock (Eq, Show, Generic) + +-- | @dispatch Hospital\@input.hospitalId ActivateSurge { … } on-appended … on-duplicate … on-failed …@. +data DispatchNode = DispatchNode + { dispTarget :: !Name + , dispKey :: !Text + , dispCommand :: !Name + , dispFields :: ![FieldBinding] + , dispDisposition :: !DispatchDisposition + , dispLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | The @on @ reaction: a self-advance, zero or more dispatches, and a +@schedule@ of the timer. +-} +data HandleNode = HandleNode + { hOn :: !Name + , hAdvance :: !AdvanceNode + , hDispatch :: ![DispatchNode] + , hSchedule :: !Name + } + deriving stock (Eq, Show, Generic) + +-- | A deterministic id derivation: @uuidv5 \"prefix:\" <> correlationId@. +data IdExpr = IdExpr + { ideStrategy :: !IdStrategy + , idePrefix :: !Text + } + deriving stock (Eq, Show, Generic) + +data IdStrategy = UuidV5Id + deriving stock (Eq, Show, Generic) + +{- | @fireAt input.observedAt + 5m@ — an injected timestamp field plus a window. +There is no clock-sampling constructor, so the no-wall-clock rule holds by +construction. +-} +data FireAtExpr = FireAtExpr + { faField :: !Name + , faWindow :: !Text + } + deriving stock (Eq, Show, Generic) + +data FireOutcome = OFired | ORetry + deriving stock (Eq, Show, Generic) + +{- | The complete timer-fire disposition table; @on-reject OFired@ is the benign +inversion (a CommandRejected means \"already applied\" = success). +-} +data FireDisposition = FireDisposition + { onOk :: !FireOutcome + , onReject :: !FireOutcome + , onAmbiguous :: !FireOutcome + , onError :: !FireOutcome + , notMine :: !FireOutcome + } + deriving stock (Eq, Show, Generic) + +-- | @fire dispatch Surge\@correlationId MarkSurgeTimerFired { … } fired-event-id … on-ok …@. +data FireNode = FireNode + { fireTarget :: !Name + , fireKey :: !Text + , fireCommand :: !Name + , fireFields :: ![FieldBinding] + , fireFiredEventId :: !IdExpr + , fireDisposition :: !FireDisposition + } + deriving stock (Eq, Show, Generic) + +-- | A nested @timer@ sub-node of a process. +data TimerNode = TimerNode + { tmName :: !Name + , tmId :: !IdExpr + , tmFireAt :: !FireAtExpr + , tmPayload :: ![FieldBinding] + , tmFire :: !FireNode + , tmDecodeUnknown :: !Name + , tmMaxAttempts :: !Int + , tmDeadLetter :: !Text + , tmLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- | A node-level worker policy lowered to the runtime worker options. +data PolicyChoice = PolHalt | PolDeadLetter | PolSkip + deriving stock (Eq, Show, Generic) + +{- | A @process@ (process manager / saga) node. The dispatch-id strategy is fixed +(runtime-owned uuidv5), so it is implicit in the AST and always rendered. +-} +data ProcessNode = ProcessNode + { procId :: !Name + -- ^ The block identifier (@process HospitalSurge@), used for module names. + , procName :: !Text + -- ^ The define-once ProcessManager @name@ (@name \"hospital-surge\"@). + , procInput :: !InputDecl + , procCorrelate :: !CorrelateDecl + , procSaga :: !SagaRef + , procTarget :: !Name + , procProjections :: ![Name] + , procHandle :: !HandleNode + , procRejected :: !PolicyChoice + , procPoison :: !PolicyChoice + , procTimer :: !TimerNode + , procLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-108: stateless, effectful content-based routing. + +data ResolveSource = ResolveReadModel !Name | ResolveHole + deriving stock (Eq, Show, Generic) + +data ResolveDecl = ResolveDecl + { rvSource :: !ResolveSource + , rvRow :: ![Name] + , rvLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +data RouterDispatchNode = RouterDispatchNode + { rdCommand :: !Name + , rdFields :: ![FieldBinding] + , rdDisposition :: !DispatchDisposition + , rdLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | A stateless router. Its fixed dispatch-id strategy is runtime-owned, and +the mandatory @stable@ token on the resolve clause is an author acknowledgement +that retry attempts accumulate the union of resolved target identities. +-} +data RouterNode = RouterNode + { rtId :: !Name + , rtName :: !Text + , rtInput :: !InputDecl + , rtKey :: !CorrelateDecl + , rtResolve :: !ResolveDecl + , rtTarget :: !Name + , rtProjections :: ![Name] + , rtDispatch :: !RouterDispatchNode + , rtRejected :: !PolicyChoice + , rtPoison :: !PolicyChoice + , rtLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-4: the cross-service @contract@ (shared Kafka message schema, define-once). + +-- | A contract field type: @typeid \"inc\"@, @text@, or @int@. +data ContractType = CTypeId !Text | CText | CInt + deriving stock (Eq, Show, Generic) + +data ContractField = ContractField + { cfName :: !Name + , cfType :: !ContractType + } + deriving stock (Eq, Show, Generic) + +-- | @event on { field: type … }@ within a contract. +data ContractEvent = ContractEvent + { ceName :: !Name + , ceTopic :: !Name + , ceFields :: ![ContractField] + } + deriving stock (Eq, Show, Generic) + +{- | A @contract@ node: the shared cross-service message schema, declared once +and referenced by both producer (@emit@) and consumer (@intake@). EP-5's +pgmq @dispatch@ also couples to it. +-} +data ContractNode = ContractNode + { ctrName :: !Name + , ctrSchemaVersion :: !Int + , ctrDiscriminator :: !Name + , ctrTopics :: ![(Name, Text)] + -- ^ (topic alias, real Kafka topic string) + , ctrEvents :: ![ContractEvent] + , ctrLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-4: the @intake@ (Kafka consumer / inbox) node. + +-- | Where an envelope field is read from on the wire. +data WireSource + = SrcHeader !Text + | SrcBody + | SrcKafkaKey + | SrcKafkaCursor + deriving stock (Eq, Show, Generic) + +-- | One envelope-binding row: @bind from [required] [cross-check body]@. +data BindRow = BindRow + { brField :: !Name + , brSource :: !WireSource + , brRequired :: !Bool + , brCrossCheck :: !Bool + } + deriving stock (Eq, Show, Generic) + +{- | An inbox outcome action. The dangerous defaults the validator guards: a +@duplicate@\/@previouslyFailed@ must not be 'IRetry'; @decodeFailed@ must not +be an unbounded 'IRetry'. +-} +data InboxAction + = IAckOk + | -- | @retry @, e.g. @retry 5s@ + IRetry !Text + | IDeadLetter !(Maybe Text) + deriving stock (Eq, Show, Generic) + +-- | One row of the mandatory, complete inbox disposition table. +data DispositionRow = DispositionRow + { drOutcome :: !Name + , drAction :: !InboxAction + , drLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- | The body decode-strictness decision (hole-kind 6). +data DecodeSpec = DecodeSpec + { decEnvelope :: !Text + -- ^ the envelope policy text, e.g. @strict-required lenient-optional@ + , decBodyStrict :: !Bool + , decBodySchemaVersion :: !Int + } + deriving stock (Eq, Show, Generic) + +-- | How much of a successfully processed envelope the inbox retains. +data InkPersist = InkPersistFull | InkPersistDedupeOnly + deriving stock (Eq, Show, Generic) + +{- | An @intake@ (Kafka consumer / inbox) node. The runtime-config @consumer@ +block (brokers/groupId/offsetReset) is hole-kind 8, delegated to deployment +and not modelled here. +-} +data IntakeNode = IntakeNode + { inkName :: !Name + , inkContract :: !Name + , inkTopic :: !Name + , inkAccept :: ![Name] + , inkBinds :: ![BindRow] + , inkDedupeKey :: !Name + , inkDedupePolicy :: !Name + , inkPersist :: !InkPersist + , inkDecode :: !DecodeSpec + , inkDisposition :: ![DispositionRow] + , inkLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-4: the @emit@ (outbox mapping) and @publisher@ nodes. + +-- | A deterministic id derivation hole: @derive [\"prefix\"] hole@. +newtype DeriveSpec = DeriveSpec {dsPrefix :: Maybe Text} + deriving stock (Eq, Show, Generic) + +-- | One @\"value\" => EventType@ row of an emit's status mapping. +data EmitMapRow = EmitMapRow + { emrValue :: !Text + , emrEvent :: !Name + , emrLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | An @emit@ (outbox) node: maps a private status discriminant to contract +event types, with a mandatory explicit @_ => skip@ catch-all. +-} +data EmitNode = EmitNode + { emName :: !Name + , emContract :: !Name + , emTopic :: !Name + , emSource :: !Text + , emKey :: !Name + , emDiscriminant :: !Name + , emMap :: ![EmitMapRow] + , emSkip :: !Bool + -- ^ whether the explicit @_ => skip@ catch-all is present + , emMessageId :: !DeriveSpec + , emIdempotencyKey :: !DeriveSpec + , emLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- | @backoff @, e.g. @backoff constant 2s@. +data BackoffSpec = BackoffSpec + { boKind :: !Name + , boWindow :: !Text + , boMax :: !(Maybe Text) + , boMultiplier :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- | A @publisher@ node: the at-least-once publishing policy for an emit's topic. +data PublisherNode = PublisherNode + { pubName :: !Name + , pubEmit :: !Name + , pubOrdering :: !Name + , pubMaxAttempts :: !Int + , pubBackoff :: !BackoffSpec + , pubOutboxField :: !Name + -- ^ @outboxId stable from @: retries coalesce on (source, this field) + , pubLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-5: the pgmq @workqueue@ + @dispatch@ nodes. + +-- | One @field -> \"wire_name\" type required@ row of a workqueue payload. +data WqField = WqField + { wqfName :: !Name + , wqfWire :: !Text + , wqfType :: !Name + , wqfRequired :: !Bool + } + deriving stock (Eq, Show, Generic) + +{- | One row of a workqueue's consumer @JobOutcome@ disposition (reusing +'InboxAction': @retry @ \/ @deadLetter@). +-} +data WqDispRow = WqDispRow + { wqdOutcome :: !Name + , wqdAction :: !InboxAction + , wqdLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- | The queue's semantic delivery-order contract. +data WqOrdering = WqUnordered | WqFifoThroughput | WqFifoRoundRobin + deriving stock (Eq, Show, Generic) + +-- | A FIFO message-group key derived from one payload field. +data WqGroupKey = WqGroupKey + { gkField :: !Name + , gkVia :: !Name + , gkFixture :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- | The PostgreSQL storage shape provisioned for a queue. +data WqProvision + = WqStandard + | WqUnlogged + | WqPartitioned !Text !Text + deriving stock (Eq, Show, Generic) + +{- | A pgmq @workqueue@ node. The @derive@ trio (physical\/dlq\/table) is a +/captured fixture/ (hole-kind 1): the validator re-derives the physical name +from @logical@ and flags any divergence (the drift hazard at the dedup site). +-} +data WorkqueueNode = WorkqueueNode + { wqName :: !Name + , wqLogical :: !Text + , wqPhysical :: !Text + , wqDlq :: !Text + , wqTable :: !Text + , wqOrdering :: !WqOrdering + , wqGroupKey :: !(Maybe WqGroupKey) + , wqProvision :: !WqProvision + , wqPayloadName :: !Name + , wqPayload :: ![WqField] + , wqMaxRetries :: !Int + , wqDelay :: !Text + , wqDlqOn :: !Bool + , wqDisposition :: ![WqDispRow] + , wqLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +{- | A pgmq @dispatch@ node: a read-model→enqueue coupling with a fan-out hole +and a dedup check (one arm of which is a raw-SQL hole). +-} +data PgmqDispatchNode = PgmqDispatchNode + { pdName :: !Name + , pdSourceReadModel :: !Name + , pdSourceKey :: !Name + , pdFanoutBody :: !Name + , pdDedupKey :: !Name + , pdDedupReadModel :: !Name + , pdDedupReadModelField :: !Text + , pdDedupQueue :: !Name + , pdDedupQueueField :: !Text + , pdEnqueueTo :: !Name + , pdLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-107: first-class read-model declarations. + +-- | One declared SQL column. The validator owns the closed type vocabulary. +data RmColumn = RmColumn + { rmcName :: !Text + , rmcType :: !Text + , rmcRequired :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | Whether the model is fed in a command transaction or by a subscription. +data RmFeed = RmInline | RmSubscription + deriving stock (Eq, Show, Generic) + +-- | Which event-log head a strong read waits for. +data RmScope = RmEntireLog | RmCategory !Text + deriving stock (Eq, Show, Generic) + +{- | A registered, versioned SQL read model. Columns define its shape identity; +the runtime table remains owned by codd migrations rather than the DSL. +-} +data ReadModelNode = ReadModelNode + { rmName :: !Name + , rmTable :: !Text + , rmSchema :: !Text + , rmColumns :: ![RmColumn] + , rmVersion :: !Int + , rmShape :: !Text + , rmConsistency :: !Consistency + , rmScope :: !(Maybe RmScope) + , rmFeed :: !RmFeed + , rmSubscription :: !(Maybe Text) + , rmLoc :: !Loc + } + deriving stock (Eq, Show, Generic) + +-- EP-6: the durable @workflow@ + @operation@ nodes. + +{- | One ordered item of a workflow body. Replay matches on the label, not the +position. (Positional constructors avoid partial record fields.) +-} +data WfBodyItem + = -- | @step