diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,244 @@ ## [Unreleased] +## [0.5.0.0] - 2026-08-01 + +### Added + +- **OKF v0.2 core semantics.** okf now tracks version 0.2 of the Open Knowledge + Format. Every family below is optional; `type` remains the only key a concept + must have, and no bundle is ever rejected for omitting one. +- `Okf.Actor`: the specification §7 actor convention, with `parseActor` (total, + never fails), `renderActor` (its exact inverse), and `isHumanActor`, which is + the single test separating the machine-confirmed trust tier from + human-reviewed. Four fields carry an actor: `generated.by`, `verified[].by`, + and `sources[].author`. +- The trust family (§5.2): `Generated`/`readGenerated`/`setGenerated` for who or + what produced a concept's content and when, and + `Verification`/`readVerified`/`setVerified` for independent confirmation. + `readVerified` accepts a bare mapping as a one-element list, as §5.2 requires. +- The lifecycle family (§5.4, §5.5): `Status`/`readStatus`/`renderStatus`/ + `setStatus`, where an absent key means `stable`, and `readStaleAfter`/ + `setStaleAfter`. +- The provenance family (§5.1): `Source`/`readSources`/`setSources` with the + credibility signals `author`, `usage_count`, and `last_modified`, plus + `UsageWindow`/`readUsageWindow`/`setUsageWindow` and `effectiveUsageWindow`, + which resolves an entry's own window against the document-scope one. + `usage_count` is read only from a YAML integer; a numeric string is not + coerced. +- `Okf.Trust`: `trustTier`, `renderTrustTier`, `latestVerification`, + `staleness`, and `renderStaleness`. Everything here is derived on read and + never stored, and no function in `okf-core` reads the clock — `staleness` + takes the current day as an argument. See + `docs/adr/8-derived-not-stored-trust-and-credibility.md`. +- `Okf.Bundle.Concept` projects six more typed fields from frontmatter — + `generated`, `verified`, `status`, `staleAfter`, `sources`, `usageWindow` — + with matching accessors. Every projection restates frontmatter; none is a + derivation. +- The bundle-root version declaration of §12: `OkfVersion`, + `VersionDeclaration`, `readBundleVersion`, `parseOkfVersion`, + `renderOkfVersion`, `supportedOkfVersion`, and `renderRootIndex` in + `Okf.Index`. `Okf.Validation.versionGate` is the one place that decides what a + declared version implies, and `gateDeclaresAtLeast` is the only question a + check asks of it. An unknown minor within a known major is read as the highest + known version; an unknown major is read permissively. Neither is ever a refusal. + See `docs/adr/10-okf-version-declaration-and-best-effort-reading.md`. +- `Okf.Markdown`, with one shared `markdownOptions` list, `extractFootnoteLabels`, + and `footnoteLabelsUsed`. All three `commonmarkToNode` call sites now route + through it and Markdown footnotes are enabled. See + `docs/adr/9-one-markdown-parse-configuration-and-source-scanned-authoring-checks.md`. +- `okf-core/test/fixtures/v01-legacy-bundle`, a deliberately unmigrated v0.1 + bundle that keeps the legacy fallback under test. Do not migrate it. +- **Object rules on profile field rules.** `FieldRule` gains + `objectFields :: Maybe NestedRules`, describing the record that *is* a key's + value, as distinct from `elementFields`, which describes the record inside each + element of a list. Both take the same `NestedRules` value and their members are + checked identically; only the reported `FieldPath` differs (`generated.by` + against `reviews[0].kind`). Declaring both accepts either spelling, which is how + a profile describes the OKF v0.2 `verified` key. `NestedFieldRule` gains + neither member, so the descriptor stays depth-bounded. + `EffectiveFieldRule` gains the `fieldRuleObjectFields` accessor, and generated + profile documentation gains an `- Object fields:` bullet. Declaring + `objectFields` and no explicit cardinality refines the rule to the new + compiled-only `Cardinality` constructor `Object`; pairing it with an explicit + `Scalar` or `List` is the new definition error + `ObjectFieldsRequireObjectShape`. See + `docs/adr/11-growing-the-profile-descriptor-language.md`. +- `okf-core/test/fixtures/profiles/object-fields-mp8-ep1.dhall`, the frozen + descriptor generation from immediately before `objectFields` existed. Do not + edit it. +- **The OKF v0.2 `Attested Computation` concept type (§10).** A concept of that + exact type carries a sanctioned way to compute a value, so a consumer can + confirm a number came from running the blessed computation rather than from an + agent improvising its own query. `Okf.Document` reads the five contract keys — + `runtime`, `parameters`, `computation`, `executor`, `attester` — with + `Parameter`, `Executor`, `Attester`, and `attestedComputationType`, the exact + case-sensitive type string. All five joined `coreFrontmatterFieldOrder` and + `fieldsIntroducedInV02`, between `status` and `generated`, which is §10.2's own + worked-example order, so serialization round-trips a §10.2 concept unchanged. + `Okf.Bundle` projects the lot onto `Concept`. +- The body half of §10.3: `Okf.Markdown.computationBlocks` finds the code blocks + under a `# Computation` heading, bounded at the next heading of the same or + shallower level, and accepts both the fenced spelling §10.3's prose names and + the indented one §10.2's own example writes. `Okf.Document.ComputationSource` + and `readComputationSources` restate what a document offers — file before + inline — and `Okf.Bundle.conceptComputationSources` projects it. Every one of + these is type-agnostic and never reports; scoping to the type is + `Okf.Validation`'s job. +- Four strict-mode `ValidationError` constructors for that type and no other: + `AttestedComputationMissingRuntime` for §10.2's one REQUIRED field, and + `AttestedComputationHasNoComputation`, `AttestedComputationHasBothComputations`, + and `AttestedComputationHasManyBlocks Int` for the three ways §10.3's + exactly-one rule breaks. Strict-only, per + `docs/adr/7-okf-v0-1-legacy-fallback-policy.md`: §11's conformance list reaches + none of them and separately forbids rejecting a bundle for an unknown `type`, + so "REQUIRED for this type" binds the producer and does not license a consumer + to refuse. +- **Path-valued frontmatter fields are resolved against the bundle** (§6.2), a + gap that predates attested computations — nothing in okf had ever looked at a + path sitting in a frontmatter value. `Okf.Path` gains existence checking, and + `Okf.Validation` reports `DanglingFrontmatterPath` under `StrictAuthoring` for + `resource`, `computation`, `executor.resource`, and `attester.resource`. A + relative path that would have resolved from the bundle root is told the + leading-slash spelling to write instead. `sources[].resource` is deliberately + excluded: §5.1 sanctions a scope descriptor there, so path-checking it would + report correct bundles as broken. See + `docs/adr/12-frontmatter-path-resolution.md`. +- `Okf.Profile.validateProfileWith` takes a `BundleInventory`, so a profile + `path` rule resolves against every file in the bundle rather than only `.md` + concepts — which is what §6.3's own `references/attesters/revenue.py` example + needs. `validateProfile` is defined in terms of it and keeps its exact meaning: + a caller that supplies no inventory has not looked, and okf reports nothing it + did not check. See `docs/adr/13-the-references-convention-and-non-markdown-files.md`. +- `Okf.Index` lists a directory's non-Markdown files under a `# Files` heading, + so a `references/attesters/` directory holding only `.py` files no longer + generates a one-byte `index.md`. +- `okf-core/test/fixtures/attested-computation/`, a bundle carrying one complete + contract, one of each §10.3 failure, one `Metric` that must never be mistaken + for a computation, and one concept that is core-clean and deviates only from a + house profile. `okf-core/test/fixtures/profiles/attested-computation-house.dhall` + is that house profile, and is the descriptor `docs/user/profiles.md` documents. +- `Okf.Profile.Documentation.defaultDocumentationActor`, the actor + `defaultDocumentationOptions` names as the producer of a generated + documentation bundle: `ProcessActor "okf-profile-document"`. Deliberately + version-free, so generated output stays byte-identical across okf releases. +- A profile may require its bundle to declare an OKF version. + `ProfileSpec.requireBundleVersion` holds a minimum as `Just "0.2"`, and the new + `Okf.Profile.validateProfileVersion` reports an undeclared, older, or + unparseable declaration as `RequiredBundleVersionUnmet`. Specification §12 + makes the declaration a MAY, so `validateBundle` still never asks for one; this + is the house-convention half, inert until a profile author writes the field. + `compiledProfileRequiredBundleVersion` reads the parsed minimum off a compiled + profile. See + `docs/adr/10-okf-version-declaration-and-best-effort-reading.md`. +- `validateProfileVersion` is a new entry point rather than a parameter on + `validateProfile` or `validateProfileWith`, whose signatures are unchanged: the + check consults no concepts, and adding a parameter would break every caller. +- The generated profile documentation bundle gains a `Required bundle version` + bullet in its `## Settings` list, so a profile setting cannot be a silent hole + in its own documentation. Regenerating a committed documentation bundle + produces that one added line. + +### Changed + +- **Breaking for exhaustive consumers, from the attested computation work.** + Four changes, listed together because a consumer moving its okf pin meets them + as one surface. `Okf.Validation.validateBundle` takes a required + `BundleInventory` before its list of concepts — required rather than defaulted, + so no caller can pass an empty inventory and have every path report as + dangling. `BundleValidationError` gains `DanglingFrontmatterPath ConceptId Text + FilePath (Maybe FilePath)`. `ValidationError` gains the four + `AttestedComputation*` constructors listed above. And `Okf.Index.renderIndex` + takes two further parameters, for the non-Markdown files in a directory. + The arity change on `validateBundle` is the one that breaks a caller outright; + the constructor additions break only an exhaustive `case`. Mori + (`mori://shinzui/mori`) matches `ProfileViolation` and not `ValidationError` or + `BundleValidationError` as of 2026-08-01, so the constructors do not reach it, + but its call to `validateBundle` does — check before moving the pin rather than + assuming, since that is a position on a date and not a guarantee. + `Okf.Profile.validateProfile` is unchanged in signature and meaning. +- **Breaking for exhaustive consumers.** `Cardinality` gains a fourth + constructor, `Object`, and `ProfileDefinitionError` gains + `ObjectFieldsRequireObjectShape`. The `Cardinality` addition is the wider of + the two: that type appears in `ConflictingCardinality`, + `ElementFieldsRequireList`, `ConditionFieldNotScalar`, and + `CardinalityMismatch`, so a consumer that renders a cardinality needs a new + case even if it declares no object rules. `Object` is deliberately unreachable + from Dhall — the published union in `okf-core/dhall/Cardinality.dhall` keeps + exactly its three alternatives — so no pinned descriptor changes type. No + `ProfileViolation` constructor was added. +- Adding `objectFields` to the closed Dhall `FieldRule` record is a schema + event. The complete optional-presence generation is frozen before it and + upgrades with `objectFields = None`, so descriptors written with record + completion or the `mk` constructors are unaffected; a descriptor that annotates + itself against okf's current schema by relative path must add the field, since + Dhall rejects the annotation before any fallback decoder runs. +- A missing member of a nested record now carries the member's `description` + prose in parentheses, as a missing top-level key already did. This applies to + list elements as well as object members, and emits nothing where a member + declares no description. +- **Breaking for exhaustive consumers.** `validateBundle` takes a + `VersionDeclaration` between the profile and the concepts: + `ValidationProfile -> VersionDeclaration -> [Concept] -> [BundleValidationError]`. + Passing `VersionUndeclared` reproduces the previous behaviour exactly. + `ValidationError` gains `MissingGeneratedField`, `GeneratedMustHaveActor`, + `SourceMissingResource`, `DuplicateSourceId`, `FootnoteLabelNotInSources`, + `SourceIdNotCited`, and `LegacyFieldInDeclaredV2`; `BundleValidationError` + gains `BundleVersionUnparseable` and `BundleVersionNotUnderstood`. Every new + diagnostic is `StrictAuthoring` only. +- **Strict validation asks for `generated` rather than `timestamp`**, falling + back to a legacy `timestamp` when `generated` is absent, so nothing that + passed before fails now. The message for a concept with neither changes from + `missing recommended field: timestamp` to + `missing generated field (or legacy timestamp)`. The fallback is silent in an + undeclared bundle and reported in one that declares `okf_version: "0.2"`; see + `docs/adr/7-okf-v0-1-legacy-fallback-policy.md`. +- **`logStaleness` reads `generated.at` first**, falling back to `timestamp`. A + v0.2 concept with no `timestamp` at all is staleness-checked for the first + time. +- `coreFrontmatterFieldOrder` gains all six v0.2 concept keys, so re-serializing + a document orders them deterministically and a closed profile + (`allowUnknownFields = False`) permits them without redeclaring. `timestamp` + moved to the end of that order, which reorders it once in any document a + producer re-serializes. +- Markdown bodies parse with footnotes enabled. This also fixes a bug: a + single-token footnote definition such as `[^src]: doc.md` previously parsed as + a link reference definition, producing a phantom dangling link. +- `setTimestamp`, `OkfCommon`'s `commonTimestamp`, and reading a v0.1 + `timestamp` are all retained. Writing v0.1 on purpose stays supported. +- `Okf.Profile.Documentation.DocumentationOptions` gains a `generated :: + Maybe Generated` field carrying the OKF v0.2 `generated` family written on + every generated document, and `defaultDocumentationOptions` now supplies one. + `Nothing` omits the key. Generation still reads no clock: `generatedAt` is + caller-supplied and absent by default. +- **Breaking for record-literal callers.** A consumer that constructs + `DocumentationOptions` as a record literal rather than by overriding + `defaultDocumentationOptions` must add the new field. The module Haddock has + always directed callers to start from `defaultDocumentationOptions` for + exactly this reason; a call site that does so is unaffected. +- **Breaking for exhaustive matchers and record-literal callers**, from + `requireBundleVersion`. `ProfileSpec` gains a field, so a consumer building one + as a record literal must add it. `ProfileViolation` gains + `RequiredBundleVersionUnmet` — the first violation that carries no `ConceptId`, + so a consumer grouping violations by concept needs a case for it — and + `ProfileDefinitionError` gains `InvalidRequiredBundleVersion`. Handle all three + before moving an okf pin. `okf profile show --json` gains a + `requireBundleVersion` key for the same reason. +- The published Dhall schema `okf-core/dhall/Profile.dhall` gains + `requireBundleVersion : Optional Text`, defaulted to `None Text` in + `okf-core/dhall/defaults/Profile.dhall`. A descriptor written as + `Profile::{ … }` is unaffected; one written as a bare record literal annotated + `: Profile` must add the member, and one pinned at an earlier release keeps + decoding through a new frozen generation + (`okf-core/test/fixtures/profiles/pre-bundle-version.dhall`). + +### Fixed + +- The sdist ships `test/fixtures/**/*.sql`. The `attested-computation` fixture + points a `computation` field at a `.sql` file, so without it `cabal test` on + the released tarball reported that path as dangling — a failure only someone + building from Hackage with tests enabled would ever have seen. + ## [0.4.0.0] - 2026-07-30 ### Added diff --git a/dhall/FieldFormat.dhall b/dhall/FieldFormat.dhall --- a/dhall/FieldFormat.dhall +++ b/dhall/FieldFormat.dhall @@ -1,7 +1,19 @@ ---| Named textual formats available to profile field rules. +--| Named value formats available to profile field rules. +-- +-- The first five constrain text. `Actor` and `HumanActor` constrain text against +-- the OKF v0.2 actor convention (specification §7): `/`, +-- `human:`, or `process:`, with `HumanActor` accepting only the second. +-- `Integer`, `NonNegativeInteger`, and `Boolean` constrain a value that is not +-- text at all, and declaring one of them refines an unspecified cardinality to +-- `Scalar`. < Rfc3339Utc | Date | Uri | UriWithScheme : Text | DocumentHandle : Text +| Actor +| HumanActor +| Integer +| NonNegativeInteger +| Boolean > diff --git a/dhall/FieldRule.dhall b/dhall/FieldRule.dhall --- a/dhall/FieldRule.dhall +++ b/dhall/FieldRule.dhall @@ -8,6 +8,21 @@ -- `allowedValues = []` leaves textual values unconstrained. -- `cardinality = Cardinality.Any` preserves the legacy scalar-or-list presence -- behavior. +-- +-- `elementFields` and `objectFields` are a pair and describe two different +-- shapes. `elementFields` describes the record inside *each element of a list*, +-- so `reviews: [{kind: human}, …]` is constrained with `elementFields`. +-- `objectFields` describes the record that *is* the value, so +-- `generated: {by: …, at: …}` is constrained with `objectFields`. Declaring both +-- means either spelling is accepted and both are checked against the same member +-- rules, which is how a profile describes the OKF v0.2 `verified` key: the +-- specification permits it as a list of mappings or as one bare mapping, and +-- requires a consumer to treat the bare mapping as a one-element list. +-- +-- Declaring `objectFields` with no explicit cardinality means the key must be a +-- mapping. Declaring it alongside `cardinality = Cardinality.Scalar` or +-- `Cardinality.List` is a profile definition error, because a mapping is +-- neither. let Cardinality = ./Cardinality.dhall let FieldFormat = ./FieldFormat.dhall @@ -18,12 +33,16 @@ let HandleReferenceRule = ./HandleReferenceRule.dhall +let PathReferenceRule = ./PathReferenceRule.dhall + in { field : Text , description : Optional Text , allowedValues : List Text , cardinality : Cardinality , format : Optional FieldFormat , elementFields : Optional NestedRules + , objectFields : Optional NestedRules , reference : Optional HandleReferenceRule + , path : Optional PathReferenceRule , when : Optional FieldCondition } diff --git a/dhall/NestedFieldRule.dhall b/dhall/NestedFieldRule.dhall --- a/dhall/NestedFieldRule.dhall +++ b/dhall/NestedFieldRule.dhall @@ -1,17 +1,30 @@ ---| Canonical schema for one field inside a list element record. +--| Canonical schema for one field inside a list element record, or inside the +-- mapping that is an object-valued field. -- --- This deliberately omits `elementFields`, so profile schemas are bounded to --- one list of flat records rather than recursively nested objects. +-- This deliberately omits `elementFields` and `objectFields`, so profile schemas +-- are bounded to one level of flat records rather than recursively nested +-- objects. +-- +-- It does carry `path`, because `sources[].resource` — the motivating +-- path-valued field of OKF v0.2 specification §6.2 — lives inside a list element +-- record and is unreachable from a top-level rule. It deliberately does not +-- carry `reference`: no v0.2 field names a `PREFIX-N` document handle inside a +-- nested record, and adding an unused member to a published record is a +-- compatibility event bought for nothing. It is a cheap additive change for +-- whoever has a motivating case. let Cardinality = ./Cardinality.dhall let FieldFormat = ./FieldFormat.dhall let FieldCondition = ./FieldCondition.dhall +let PathReferenceRule = ./PathReferenceRule.dhall + in { field : Text , description : Optional Text , allowedValues : List Text , cardinality : Cardinality , format : Optional FieldFormat + , path : Optional PathReferenceRule , when : Optional FieldCondition } diff --git a/dhall/PathReferenceRule.dhall b/dhall/PathReferenceRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/PathReferenceRule.dhall @@ -0,0 +1,20 @@ +--| Policy for a field whose value names a path or URI per OKF v0.2 +-- specification §6.2: an absolute URL, a bundle-relative path beginning with +-- `/`, or an ordinary relative path. A relative path resolves against the +-- directory of the concept carrying it, exactly as a Markdown link in that +-- concept's body would. +-- +-- Deliberately distinct from `HandleReferenceRule`, which resolves a `PREFIX-N` +-- document handle against the bundle's document-ID index. A path resolves +-- against the bundle's concept tree instead, and declaring both policies on one +-- key is a profile definition error: a value cannot be read as both. +-- +-- `externalUriSchemes` lists the URL schemes the profile permits; an empty list +-- means no absolute URL is permitted and the value must be a path. okf resolves +-- only paths, and only to concepts: a path naming a `.md` file must name one +-- that exists in the bundle, and a path naming any other file is accepted +-- without a check, because profile validation never touches the filesystem. +-- `allowSelf` permits a path that resolves to the concept carrying it. +{ externalUriSchemes : List Text +, allowSelf : Bool +} diff --git a/dhall/Profile.dhall b/dhall/Profile.dhall --- a/dhall/Profile.dhall +++ b/dhall/Profile.dhall @@ -16,6 +16,13 @@ -- read or adopt it. Like every description in this schema it is documentary only. -- `allowUnknownFields = False` closes top-level frontmatter to core OKF keys, -- the configured `idField`, and the effective profile/type field rules. +-- +-- `requireBundleVersion = Some "0.2"` means the bundle's root `index.md` must +-- declare `okf_version` at that version or later; `None Text` demands nothing and +-- is the default. This is a house convention, not a rule of the format: +-- specification §12 makes the declaration a MAY, so okf itself never asks for one. +-- It is distinct from `okfVersion` above, which says which version's rules this +-- profile writes rather than what it demands of a bundle. let TypeRule = ./TypeRule.dhall let FrontmatterRules = ./FrontmatterRules.dhall @@ -27,5 +34,6 @@ , allowUnknownTypes : Bool , allowUnknownFields : Bool , idField : Optional Text + , requireBundleVersion : Optional Text , types : List TypeRule } diff --git a/dhall/defaults/FieldRule.dhall b/dhall/defaults/FieldRule.dhall --- a/dhall/defaults/FieldRule.dhall +++ b/dhall/defaults/FieldRule.dhall @@ -11,6 +11,8 @@ let HandleReferenceRule = ../HandleReferenceRule.dhall +let PathReferenceRule = ../PathReferenceRule.dhall + in { Type = FieldRuleType , default = { description = None Text @@ -18,7 +20,9 @@ , cardinality = Cardinality.Any , format = None FieldFormat , elementFields = None NestedRules + , objectFields = None NestedRules , reference = None HandleReferenceRule + , path = None PathReferenceRule , when = None FieldCondition } } diff --git a/dhall/defaults/NestedFieldRule.dhall b/dhall/defaults/NestedFieldRule.dhall --- a/dhall/defaults/NestedFieldRule.dhall +++ b/dhall/defaults/NestedFieldRule.dhall @@ -7,12 +7,15 @@ let FieldCondition = ../FieldCondition.dhall +let PathReferenceRule = ../PathReferenceRule.dhall + in { Type = NestedFieldRuleType , default = { description = None Text , allowedValues = [] : List Text , cardinality = Cardinality.Any , format = None FieldFormat + , path = None PathReferenceRule , when = None FieldCondition } } diff --git a/dhall/defaults/PathReferenceRule.dhall b/dhall/defaults/PathReferenceRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/defaults/PathReferenceRule.dhall @@ -0,0 +1,13 @@ +--| Record-completion defaults for a path-valued field policy. +-- +-- The defaults are the strictest coherent policy: no absolute URL is permitted, +-- so the value must be a path, and a path resolving to the concept carrying it +-- is reported. An author widens from there. +let PathReferenceRule = ../PathReferenceRule.dhall + +in { Type = PathReferenceRule + , default = + { externalUriSchemes = [] : List Text + , allowSelf = False + } + } diff --git a/dhall/defaults/Profile.dhall b/dhall/defaults/Profile.dhall --- a/dhall/defaults/Profile.dhall +++ b/dhall/defaults/Profile.dhall @@ -13,6 +13,7 @@ , allowUnknownTypes = True , allowUnknownFields = True , idField = None Text + , requireBundleVersion = None Text , types = [] : List TypeRule } } diff --git a/dhall/mk/FieldRule.dhall b/dhall/mk/FieldRule.dhall --- a/dhall/mk/FieldRule.dhall +++ b/dhall/mk/FieldRule.dhall @@ -24,6 +24,8 @@ let HandleReferenceRule = ../defaults/HandleReferenceRule.dhall +let PathReferenceRule = ../defaults/PathReferenceRule.dhall + in { plain = \(field : Text) -> FieldRule::{ field } , documented = \(field : Text) -> @@ -51,6 +53,16 @@ \(field : Text) -> \(prefix : Text) -> FieldRule::{ field, format = Some (FieldFormat.DocumentHandle prefix) } + , actor = \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Actor } + , humanActor = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.HumanActor } + , integer = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Integer } + , nonNegativeInteger = + \(field : Text) -> + FieldRule::{ field, format = Some FieldFormat.NonNegativeInteger } + , boolean = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Boolean } , recordList = \(field : Text) -> \(elementFields : NestedRules) -> @@ -59,6 +71,18 @@ , cardinality = Cardinality.List , elementFields = Some elementFields } + , record = + \(field : Text) -> + \(objectFields : NestedRules) -> + FieldRule::{ field, objectFields = Some objectFields } + , recordOrList = + \(field : Text) -> + \(fields : NestedRules) -> + FieldRule::{ + , field + , objectFields = Some fields + , elementFields = Some fields + } , conditional = \(rule : FieldRule.Type) -> \(condition : FieldCondition) -> @@ -78,5 +102,13 @@ , field , reference = Some HandleReferenceRule::{ localPrefix, externalUriSchemes } + } + , bundlePath = \(field : Text) -> FieldRule::{ field, path = Some PathReferenceRule::{=} } + , localOrExternalPath = + \(field : Text) -> + \(externalUriSchemes : List Text) -> + FieldRule::{ + , field + , path = Some PathReferenceRule::{ externalUriSchemes } } } diff --git a/dhall/mk/NestedFieldRule.dhall b/dhall/mk/NestedFieldRule.dhall --- a/dhall/mk/NestedFieldRule.dhall +++ b/dhall/mk/NestedFieldRule.dhall @@ -7,6 +7,8 @@ let FieldCondition = ../FieldCondition.dhall +let PathReferenceRule = ../defaults/PathReferenceRule.dhall + in { plain = \(field : Text) -> NestedFieldRule::{ field } , documented = \(field : Text) -> @@ -34,8 +36,31 @@ \(field : Text) -> \(prefix : Text) -> NestedFieldRule::{ field, format = Some (FieldFormat.DocumentHandle prefix) } + , actor = + \(field : Text) -> NestedFieldRule::{ field, format = Some FieldFormat.Actor } + , humanActor = + \(field : Text) -> + NestedFieldRule::{ field, format = Some FieldFormat.HumanActor } + , integer = + \(field : Text) -> NestedFieldRule::{ field, format = Some FieldFormat.Integer } + , nonNegativeInteger = + \(field : Text) -> + NestedFieldRule::{ field, format = Some FieldFormat.NonNegativeInteger } + , boolean = + \(field : Text) -> + NestedFieldRule::{ field, format = Some FieldFormat.Boolean } , conditional = \(rule : NestedFieldRule.Type) -> \(condition : FieldCondition) -> rule with when = Some condition + , bundlePath = + \(field : Text) -> + NestedFieldRule::{ field, path = Some PathReferenceRule::{=} } + , localOrExternalPath = + \(field : Text) -> + \(externalUriSchemes : List Text) -> + NestedFieldRule::{ + , field + , path = Some PathReferenceRule::{ externalUriSchemes } + } } diff --git a/dhall/package.dhall b/dhall/package.dhall --- a/dhall/package.dhall +++ b/dhall/package.dhall @@ -19,6 +19,7 @@ , FieldRule = ./FieldRule.dhall , FieldCondition = ./FieldCondition.dhall , HandleReferenceRule = ./HandleReferenceRule.dhall +, PathReferenceRule = ./PathReferenceRule.dhall , NestedRules = ./NestedRules.dhall , NestedFieldRule = ./NestedFieldRule.dhall , Cardinality = ./Cardinality.dhall @@ -29,6 +30,7 @@ , FrontmatterRules = ./defaults/FrontmatterRules.dhall , FieldRule = ./defaults/FieldRule.dhall , HandleReferenceRule = ./defaults/HandleReferenceRule.dhall + , PathReferenceRule = ./defaults/PathReferenceRule.dhall , NestedRules = ./defaults/NestedRules.dhall , NestedFieldRule = ./defaults/NestedFieldRule.dhall } diff --git a/okf-core.cabal b/okf-core.cabal --- a/okf-core.cabal +++ b/okf-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: okf-core -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Read, validate, index, and traverse Open Knowledge Format bundles @@ -22,10 +22,15 @@ -- The canonical profile schema, plus the fixtures okf-core-test reads. The -- fixture descriptors import the schema through ../../../dhall, so both trees -- must ship for `cabal test` to work from the sdist. +-- The .py and .sql files are not a mistake: the dangling-frontmatter-path and +-- attested-computation fixtures need non-Markdown files in the bundle, because +-- resolving a path to one is the whole point of the checks they exercise. extra-source-files: dhall/**/*.dhall test/fixtures/**/*.dhall test/fixtures/**/*.md + test/fixtures/**/*.py + test/fixtures/**/*.sql common common-options ghc-options: @@ -45,6 +50,7 @@ import: common-options hs-source-dirs: src exposed-modules: + Okf.Actor Okf.Bundle Okf.ConceptId Okf.Discovery @@ -52,9 +58,13 @@ Okf.Graph Okf.Index Okf.Log + Okf.Markdown + Okf.Path Okf.Prelude Okf.Profile + Okf.Profile.Documentation Okf.Profile.Registry + Okf.Trust Okf.Validation build-depends: @@ -84,6 +94,7 @@ build-depends: , aeson , base >=4.20 && <5 + , containers >=0.6 && <0.8 , dhall >=1.41 && <1.43 , directory , filepath diff --git a/src/Okf/Actor.hs b/src/Okf/Actor.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Actor.hs @@ -0,0 +1,68 @@ +-- | The OKF v0.2 actor convention (specification §7). +-- +-- Fields that record an identity — @generated.by@, @verified[].by@, and +-- @sources[].author@ — all carry an /actor/: a short string naming who or what +-- acted. The specification defines exactly three shapes, and consumers that +-- classify trust (§5.3) key off the @human:@ prefix, so the prefix test lives +-- here once rather than being re-derived by each reader. +module Okf.Actor + ( Actor (..), + parseActor, + renderActor, + isHumanActor, + ) +where + +import Data.Text qualified as Text +import Okf.Prelude + +-- | An actor as defined by OKF v0.2 specification §7. +-- +-- 'parseActor' is total: text matching none of the three shapes becomes +-- 'UnclassifiedActor' rather than a parse failure, because §11 forbids +-- rejecting a document for a malformed optional field. Reporting an +-- unclassified actor is a validation decision, not a parsing one. +data Actor + = -- | @human:\@ per specification §7, carrying the id. + HumanActor !Text + | -- | @process:\@ per specification §7, carrying the id. + ProcessActor !Text + | -- | @\/\@ per specification §7, carrying producer then version. + ProducerActor !Text !Text + | -- | Text matching none of the three shapes, preserved verbatim. + UnclassifiedActor !Text + deriving stock (Generic, Eq, Ord, Show) + +-- | Classify an actor string. Never fails. +-- +-- The @human:@ and @process:@ prefixes are matched before the @\/@ split and +-- matching is case-sensitive, because §7 writes them in lower case and §5.3 +-- makes the @human:@ test the sole discriminator between trust tiers. A value +-- such as @Human:ahormati@ is therefore 'UnclassifiedActor'. +-- +-- @'renderActor' . 'parseActor'@ is the identity on every input. +parseActor :: Text -> Actor +parseActor raw + | Just actorId <- Text.stripPrefix "human:" raw, not (Text.null actorId) = HumanActor actorId + | Just actorId <- Text.stripPrefix "process:" raw, not (Text.null actorId) = ProcessActor actorId + | (producer, versionWithSlash) <- Text.breakOn "/" raw, + Just version <- Text.stripPrefix "/" versionWithSlash, + not (Text.null producer), + not (Text.null version) = + ProducerActor producer version + | otherwise = UnclassifiedActor raw + +-- | Render an actor back to the text a producer wrote. Inverse of 'parseActor'. +renderActor :: Actor -> Text +renderActor = \case + HumanActor actorId -> "human:" <> actorId + ProcessActor actorId -> "process:" <> actorId + ProducerActor producer version -> producer <> "/" <> version + UnclassifiedActor raw -> raw + +-- | Whether the actor is a person. Specification §5.3 makes this the sole +-- discriminator between the machine-confirmed and human-reviewed trust tiers. +isHumanActor :: Actor -> Bool +isHumanActor = \case + HumanActor _ -> True + _ -> False diff --git a/src/Okf/Bundle.hs b/src/Okf/Bundle.hs --- a/src/Okf/Bundle.hs +++ b/src/Okf/Bundle.hs @@ -1,17 +1,33 @@ -- | Bundle-level discovery for OKF concept documents. module Okf.Bundle ( BundleError (..), + BundleInventory, Concept, LogFile (..), + bundleInventoryMember, + bundleInventoryOfConcepts, + walkBundleInventory, conceptFromDocument, + conceptAttester, + conceptComputation, + conceptComputationSources, conceptDescription, conceptDocument, + conceptExecutor, + conceptGenerated, conceptIdOf, + conceptParameters, conceptResource, + conceptRuntime, conceptSourcePath, + conceptSources, + conceptStaleAfter, + conceptStatus, conceptTags, + conceptUsageWindow, conceptTitle, conceptType, + conceptVerified, findConcept, findConceptsByDocumentId, isReservedMarkdownFile, @@ -25,6 +41,8 @@ import Control.Exception (IOException, try) import Data.Aeson.KeyMap qualified as KeyMap import Data.List qualified as List +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Okf.ConceptId @@ -49,7 +67,19 @@ title :: !(Maybe Text), description :: !(Maybe Text), resource :: !(Maybe Text), - tags :: ![Text] + tags :: ![Text], + generated :: !(Maybe Generated), + verified :: ![Verification], + status :: !Status, + staleAfter :: !(Maybe Text), + sources :: ![Source], + usageWindow :: !(Maybe UsageWindow), + runtime :: !(Maybe Text), + parameters :: ![Parameter], + computation :: !(Maybe Text), + executor :: !(Maybe Executor), + attester :: !(Maybe Attester), + computationSources :: ![ComputationSource] } deriving stock (Generic, Eq, Show) @@ -60,6 +90,18 @@ | BundleIoError FilePath Text deriving stock (Generic, Eq, Show) +-- | Every regular file in a bundle, as bundle-relative paths, whether or not okf +-- can parse it. Concepts are the @.md@ subset; a @references\/@ script, a CSV, or +-- an image is here and nowhere else. +-- +-- This exists so that a path-valued frontmatter field can be resolved without +-- giving validation a filesystem handle. Validation is offline by design +-- (@docs\/adr\/5-compile-profile-rules-before-validation.md@): it receives parsed +-- values and decides. Reading the inventory once during the walk, where okf is +-- already doing IO, keeps it that way. +newtype BundleInventory = BundleInventory (Set FilePath) + deriving stock (Generic, Eq, Show) + -- | A parsed @log.md@ reserved file discovered in a bundle. data LogFile = LogFile { logSourcePath :: !FilePath, @@ -87,6 +129,38 @@ results <- mapM (readLog root) paths pure (List.sortOn logSourcePath <$> sequenceA results) +-- | Record every regular file in a bundle, including the ones okf cannot parse. +-- +-- A second, independent traversal rather than a widening of 'walkBundle', whose +-- @[Concept]@ result every caller in both packages depends on. Walking twice is +-- mildly wasteful and is the right trade for a change that cannot alter what +-- 'walkBundle' returns. +-- +-- Reserved files (@index.md@, @log.md@) are recorded here even though they are +-- not concepts: they are files, and a path-valued field naming one names +-- something that exists. +walkBundleInventory :: FilePath -> IO (Either BundleError BundleInventory) +walkBundleInventory root = do + discovered <- discoverAllFiles root "" + pure (BundleInventory . Set.fromList <$> discovered) + +-- | Whether the bundle contains a file at the given bundle-relative path. The +-- path is normalised the same way the inventory's entries are, so a caller may +-- pass 'Okf.Path.collapseBundlePath' output directly. +bundleInventoryMember :: FilePath -> BundleInventory -> Bool +bundleInventoryMember path (BundleInventory paths) = + Set.member (FilePath.normalise path) paths + +-- | The inventory an in-memory bundle can honestly report: the concepts' own +-- source paths and nothing else. +-- +-- For producers that assemble concepts without a directory to walk. Such a +-- bundle resolves concept-to-concept paths correctly and simply cannot know +-- about a non-Markdown file, because there is no filesystem holding one. +bundleInventoryOfConcepts :: [Concept] -> BundleInventory +bundleInventoryOfConcepts concepts = + BundleInventory (Set.fromList (FilePath.normalise . conceptSourcePath <$> concepts)) + -- | Find a concept by identifier in an already walked bundle. findConcept :: ConceptId -> [Concept] -> Maybe Concept findConcept conceptId = @@ -137,6 +211,91 @@ conceptTags :: Concept -> [Text] conceptTags Concept {tags} = tags +-- | The OKF v0.2 @generated@ family projected from frontmatter, or 'Nothing' +-- when the concept carries none (or carries one without the @by@ actor that +-- specification §5.2 requires within it). +conceptGenerated :: Concept -> Maybe Generated +conceptGenerated Concept {generated} = generated + +-- | The OKF v0.2 @verified@ family projected from frontmatter, empty when the +-- concept carries none. A bare @{ by, at }@ mapping projects as one element, +-- per the specification §5.2 MUST. +-- +-- Note what is /not/ here: the trust tier §5.3 derives from this list is a +-- function of it, not a field beside it. See +-- @docs\/adr\/8-derived-not-stored-trust-and-credibility.md@ and use +-- @Okf.Trust.trustTier . conceptVerified@. +conceptVerified :: Concept -> [Verification] +conceptVerified Concept {verified} = verified + +-- | The OKF v0.2 @status@ lifecycle field, 'Stable' when the concept carries +-- none (specification §5.4). +conceptStatus :: Concept -> Status +conceptStatus Concept {status} = status + +-- | The OKF v0.2 @stale_after@ date read verbatim (specification §5.5). +-- Interpreting it against a calendar day is 'Okf.Trust.staleness''s job. +conceptStaleAfter :: Concept -> Maybe Text +conceptStaleAfter Concept {staleAfter} = staleAfter + +-- | The OKF v0.2 @sources@ provenance entries projected from frontmatter, +-- empty when the concept carries none (specification §5.1). Entries lacking the +-- required @resource@ are absent here; 'Okf.Validation.validateDocument' +-- reports them. +conceptSources :: Concept -> [Source] +conceptSources Concept {sources} = sources + +-- | The document-scope @usage_window@ that frames every entry's @usage_count@ +-- (specification §5.1). Resolve a given entry's effective window with +-- @Okf.Document.effectiveUsageWindow (conceptUsageWindow concept)@, which +-- honours a per-entry override. +conceptUsageWindow :: Concept -> Maybe UsageWindow +conceptUsageWindow Concept {usageWindow} = usageWindow + +-- | The @runtime@ that says how an attested computation is run, and so what its +-- @parameters@ mean (specification §10.2). +-- +-- Present on any concept that declares it, not only on one whose @type@ is +-- @Attested Computation@: a projection restates what frontmatter says and +-- nothing more. Only 'Okf.Validation.validateDocument' knows that the field is +-- REQUIRED for that one type. +conceptRuntime :: Concept -> Maybe Text +conceptRuntime Concept {runtime} = runtime + +-- | The typed, named holes an agent may fill (specification §10.2), empty when +-- the concept declares none. An entry with no @name@ is absent here. +conceptParameters :: Concept -> [Parameter] +conceptParameters Concept {parameters} = parameters + +-- | The §6.2 path to a file holding the computation, when the concept names one +-- instead of carrying an inline body fence (specification §10.2, §10.3). +-- +-- Verbatim, and not resolved against the bundle. Resolving a path-valued +-- frontmatter field is 'Okf.Validation.validateBundle''s job, which has the +-- 'BundleInventory' this projection does not. +conceptComputation :: Concept -> Maybe Text +conceptComputation Concept {computation} = computation + +-- | How the computation is run and what evidence a run must return +-- (specification §10.2). okf never runs it; §10.5 places the run and its receipt +-- outside the bundle. +conceptExecutor :: Concept -> Maybe Executor +conceptExecutor Concept {executor} = executor + +-- | The deterministic, no-LLM check that inspects a receipt (specification +-- §10.2). okf never runs it and never computes a verdict. +conceptAttester :: Concept -> Maybe Attester +conceptAttester Concept {attester} = attester + +-- | Every computation the concept offers (specification §10.3), file before +-- inline. Empty when it offers none. +-- +-- Unlike 'conceptComputation', which restates the frontmatter key verbatim, this +-- also sees the body. §10.3's rule that exactly one of the two forms must be +-- present is 'Okf.Validation.validateDocument''s to report. +conceptComputationSources :: Concept -> [ComputationSource] +conceptComputationSources Concept {computationSources} = computationSources + -- | Reserved Markdown filenames are not normal concept documents. isReservedMarkdownFile :: FilePath -> Bool isReservedMarkdownFile path = @@ -171,6 +330,31 @@ ) pure (concat <$> sequenceA discovered) +-- | Every regular file under the root, bundle-relative and normalised. Skips +-- directories, recursing into them rather than recording them, because a +-- path-valued field names a file. +discoverAllFiles :: FilePath -> FilePath -> IO (Either BundleError [FilePath]) +discoverAllFiles root relativeDir = do + let absoluteDir = root relativeDir + displayDir = if null relativeDir then root else relativeDir + listed <- tryBundleIo displayDir (listDirectory absoluteDir) + case listed of + Left bundleError -> pure (Left bundleError) + Right entries -> do + discovered <- + for + (List.sort entries) + ( \entry -> do + let relativePath = relativeDir entry + absolutePath = root relativePath + isDirectory <- tryBundleIo relativePath (doesDirectoryExist absolutePath) + case isDirectory of + Left bundleError -> pure (Left bundleError) + Right True -> discoverAllFiles root relativePath + Right False -> pure (Right [FilePath.normalise relativePath]) + ) + pure (concat <$> sequenceA discovered) + discoverLogFiles :: FilePath -> FilePath -> IO (Either BundleError [FilePath]) discoverLogFiles root relativeDir = do let absoluteDir = root relativeDir @@ -249,8 +433,20 @@ ) -- | Build a 'Concept' from its identity and document. The typed projection --- fields (@type_@, @title@, @description@, @resource@, @tags@) are derived from --- the document's frontmatter, so they can never disagree with it. The source +-- fields (@type_@, @title@, @description@, @resource@, @tags@, @generated@, +-- @verified@, @status@, @staleAfter@, @sources@, @usageWindow@, @runtime@, +-- @parameters@, @computation@, @executor@, @attester@) are derived +-- from the document's frontmatter, so they can never disagree with it. +-- A projection may only restate what frontmatter says; it may never store a +-- derivation frontmatter does not carry. +-- +-- @computationSources@ is the one field derived from the whole document rather +-- than from frontmatter alone, because specification §10.3 makes the +-- @computation@ key and the body's @# Computation@ section alternatives to each +-- other. Restating what the /document/ says, both halves together, is still +-- restating rather than deriving. +-- +-- The source -- path is derived from the concept ID. Use this when assembling concepts in -- memory (for 'writeBundle' or 'Okf.Validation.validateBundle'). conceptFromDocument :: ConceptId -> OKFDocument -> Concept @@ -268,7 +464,19 @@ title = optionalTextField "title" (frontmatter document), description = optionalTextField "description" (frontmatter document), resource = optionalTextField "resource" (frontmatter document), - tags = tagsField (frontmatter document) + tags = tagsField (frontmatter document), + generated = readGenerated (frontmatter document), + verified = readVerified (frontmatter document), + status = readStatus (frontmatter document), + staleAfter = readStaleAfter (frontmatter document), + sources = readSources (frontmatter document), + usageWindow = readUsageWindow (frontmatter document), + runtime = readRuntime (frontmatter document), + parameters = readParameters (frontmatter document), + computation = readComputation (frontmatter document), + executor = readExecutor (frontmatter document), + attester = readAttester (frontmatter document), + computationSources = readComputationSources document } textField :: Text -> Frontmatter -> Text diff --git a/src/Okf/Document.hs b/src/Okf/Document.hs --- a/src/Okf/Document.hs +++ b/src/Okf/Document.hs @@ -7,9 +7,43 @@ frontmatterLookup, frontmatterKeys, coreFrontmatterFields, + fieldsIntroducedInV02, + fieldsSupersededInV02, parseDocument, serializeDocument, + -- * OKF v0.2 trust family + Generated (..), + readGenerated, + Verification (..), + readVerified, + + -- * OKF v0.2 lifecycle family + Status (..), + readStatus, + renderStatus, + readStaleAfter, + + -- * OKF v0.2 provenance family + Source (..), + UsageWindow (..), + readSources, + readUsageWindow, + effectiveUsageWindow, + + -- * OKF v0.2 attested computation family + Parameter (..), + Executor (..), + Attester (..), + attestedComputationType, + readRuntime, + readParameters, + readComputation, + readExecutor, + readAttester, + ComputationSource (..), + readComputationSources, + -- * Frontmatter authoring frontmatterFromFields, setField, @@ -20,15 +54,23 @@ setTitle, setDescription, setTimestamp, + setGenerated, + setVerified, + setStatus, + setStaleAfter, + setSources, + setUsageWindow, setResource, setTags, ) where +import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as KeyMap import Data.Attoparsec.ByteString qualified as Attoparsec import Data.ByteString qualified as ByteString +import Data.Foldable (toList) import Data.Frontmatter qualified as Frontmatter import Data.List qualified as List import Data.Ord (comparing) @@ -39,6 +81,8 @@ import Data.Vector qualified as Vector import Data.Yaml qualified as Yaml import Data.Yaml.Pretty qualified as YamlPretty +import Okf.Actor (Actor, parseActor, renderActor) +import Okf.Markdown (computationBlocks) import Okf.Prelude hiding (setField) -- | YAML frontmatter fields. OKF allows producer-defined extension keys, so @@ -83,6 +127,470 @@ coreFrontmatterFields :: Set Text coreFrontmatterFields = Set.fromList coreFrontmatterFieldOrder +-- | The OKF v0.2 @generated@ family (specification §5.2): who or what produced +-- the concept's current content, and when. +-- +-- @generatedAt@ stays 'Text' rather than a parsed time value for two reasons. +-- §5.2 does not mark @at@ required within the mapping, and okf's convention is +-- to keep frontmatter values exactly as the producer wrote them so +-- serialization round-trips. Checking the value against ISO 8601 belongs to the +-- profile layer, which already has an @Rfc3339Utc@ format for it. +data Generated = Generated + { generatedBy :: !Actor, + generatedAt :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | Read the @generated@ family from frontmatter. +-- +-- Returns 'Nothing' when the key is absent, when its value is not a YAML +-- mapping, or when the mapping has no textual @by@ — §5.2 makes @by@ REQUIRED +-- within @generated@, so a mapping without one is not a 'Generated'. This never +-- fails: a malformed value is simply not read, because §11 forbids rejecting a +-- document for a malformed optional field. Reporting it is +-- 'Okf.Validation.validateDocument''s job. +readGenerated :: Frontmatter -> Maybe Generated +readGenerated frontmatterValue = + case frontmatterLookup "generated" frontmatterValue of + Just (Object generatedFields) -> do + by <- objectText "by" generatedFields + pure (Generated (parseActor by) (objectText "at" generatedFields)) + _ -> Nothing + +-- | One entry of the OKF v0.2 @verified@ family (specification §5.2): who or +-- what independently confirmed the content, and when. +-- +-- Deliberately distinct from 'Generated'. §5.2: "who /wrote/ a concept need not +-- be who /confirmed/ it", and the two are independent — "content can change +-- without re-confirmation, and facts can be re-confirmed without regeneration." +-- +-- @verificationAt@ stays 'Text' for the same two reasons as 'generatedAt': §5.2 +-- does not mark @at@ required within an entry, and okf preserves frontmatter +-- values as the producer wrote them so serialization round-trips. +data Verification = Verification + { verificationBy :: !Actor, + verificationAt :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | Read the OKF v0.2 @verified@ family from frontmatter. +-- +-- Handles the two shapes §5.2 permits. A YAML list of mappings yields one +-- 'Verification' per element. A __bare mapping__ yields a one-element list: +-- "Consumers MUST treat a bare mapping as a one-element list", restated in §11's +-- conformance list. Anything else, including an absent key, yields @[]@. +-- +-- An entry with no textual @by@ is skipped rather than yielding a partial +-- 'Verification', mirroring 'readGenerated'. An empty result is therefore +-- indistinguishable from an absent key, which is correct: §5.3 keys the +-- unverified tier off the absence of usable verification. +readVerified :: Frontmatter -> [Verification] +readVerified frontmatterValue = + case frontmatterLookup "verified" frontmatterValue of + Just (Array entries) -> foldMap (toList . verificationFromValue) entries + Just bareMapping -> toList (verificationFromValue bareMapping) + Nothing -> [] + where + verificationFromValue = \case + Object entryFields -> do + by <- objectText "by" entryFields + pure (Verification (parseActor by) (objectText "at" entryFields)) + _ -> Nothing + +-- | The OKF v0.2 @status@ lifecycle field (specification §5.4). +-- +-- 'UnknownStatus' carries a value outside the three the specification names, +-- verbatim. §11 forbids rejecting a concept for an unexpected optional value, +-- and preserving the text is what lets 'renderStatus' reproduce exactly what +-- the producer wrote. +data Status + = -- | @draft@: not yet reviewed; possibly incomplete. + Draft + | -- | @stable@: ready for consumption. Also the value an absent key means. + Stable + | -- | @deprecated@: kept for links and history; no longer current. + Deprecated + | -- | A value outside the three named in §5.4, preserved as written. + UnknownStatus !Text + deriving stock (Generic, Eq, Ord, Show) + +-- | Read the OKF v0.2 @status@ field (specification §5.4). +-- +-- An absent key, or a value that is not text, yields 'Stable': §5.4 states +-- "Absent @status@ ⇒ @stable@". Matching is case-sensitive, consistent with the +-- actor convention of §7 — the specification writes all three values in lower +-- case, and a case-insensitive match would quietly accept a value it should +-- surface as unknown. +readStatus :: Frontmatter -> Status +readStatus frontmatterValue = + case frontmatterLookup "status" frontmatterValue of + Just (String "draft") -> Draft + Just (String "stable") -> Stable + Just (String "deprecated") -> Deprecated + Just (String other) -> UnknownStatus other + _ -> Stable + +-- | Render a status back to the text a producer wrote. Inverse of 'readStatus' +-- on every value except an absent key, which reads as 'Stable'. +renderStatus :: Status -> Text +renderStatus = \case + Draft -> "draft" + Stable -> "stable" + Deprecated -> "deprecated" + UnknownStatus other -> other + +-- | Read the OKF v0.2 @stale_after@ field (specification §5.5) verbatim. +-- +-- Deliberately unparsed. §5.5 specifies an absolute @YYYY-MM-DD@ date, but +-- parsing here would either lose a malformed value on serialization or force +-- this total reader to fail. Interpreting the date is 'Okf.Trust.staleness''s +-- job, where a comparison is actually needed. +readStaleAfter :: Frontmatter -> Maybe Text +readStaleAfter frontmatterValue = + case frontmatterLookup "stale_after" frontmatterValue of + Just (String value) -> Just value + _ -> Nothing + +-- | The date range over which a @usage_count@ was counted (specification §5.1). +-- +-- Written once as a sibling of @sources@ to frame every entry's count; a single +-- entry MAY carry its own to override the shared one. Both bounds stay 'Text' +-- and are not parsed into a @Day@, consistent with every other date in the v0.2 +-- families: okf preserves the producer's text so serialization round-trips, and +-- format checking belongs to the profile layer's @Date@ format. +data UsageWindow = UsageWindow + { usageWindowFrom :: !(Maybe Text), + usageWindowTo :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | One entry of the OKF v0.2 @sources@ family (specification §5.1): a piece of +-- material this concept was derived from, with the optional credibility signals +-- a consumer uses to judge it. +-- +-- §5.1 records objective signals rather than a score, because a score "is +-- subjective, unportable across consumers, and goes stale". Nothing here +-- computes a verdict; see +-- @docs\/adr\/8-derived-not-stored-trust-and-credibility.md@. +data Source = Source + { -- | Optional stable key used to attribute individual claims. §5.1: SHOULD + -- be present when the body cites the source. + sourceId :: !(Maybe Text), + -- | REQUIRED within an entry. Either a concrete artifact a consumer can + -- follow (absolute URL, bundle-relative path, @references\/@ path) __or a + -- population or scope descriptor it cannot__, such as + -- @all queries in BigQuery project X@. Never treat this as a path. + sourceResource :: !Text, + -- | Optional human-readable label. + sourceTitle :: !(Maybe Text), + -- | Credibility signal: who or what produced the source, in the §7 actor + -- convention. An authority signal. + sourceAuthor :: !(Maybe Actor), + -- | Credibility signal: how often the resource was exercised over the + -- effective 'UsageWindow'. An adoption and liveness signal. §5.1 warns it + -- is coarse — comparable at the alive-versus-dead and order-of-magnitude + -- level, not as a precise ranking — so do not sort or score by it. + sourceUsageCount :: !(Maybe Integer), + -- | Credibility signal: when the source itself last changed. A recency + -- signal, distinct from @generated.at@ (§5.2), which records when the + -- /concept/ was written. + sourceLastModified :: !(Maybe Text), + -- | An entry-local window overriding the document-scope one. Resolve with + -- 'effectiveUsageWindow' rather than reading this directly. + sourceUsageWindow :: !(Maybe UsageWindow) + } + deriving stock (Generic, Eq, Show) + +-- | Read the OKF v0.2 @sources@ family from frontmatter (specification §5.1). +-- +-- An entry without a usable @resource@ is skipped, because §5.1 makes it +-- REQUIRED within an entry and a 'Source' without one would be meaningless. +-- Reporting the skipped entry is 'Okf.Validation.validateDocument''s job; this +-- reader stays total so §11's prohibition on rejecting a document is never at +-- risk. +-- +-- @usage_count@ is read only from a YAML integer. A numeric string such as +-- @"5000"@ yields 'Nothing': coercing it would make the field's type +-- unpredictable for downstream consumers and would hide a producer mistake. +readSources :: Frontmatter -> [Source] +readSources frontmatterValue = + case frontmatterLookup "sources" frontmatterValue of + Just (Array entries) -> foldMap (toList . sourceFromValue) entries + _ -> [] + where + sourceFromValue = \case + Object entryFields -> do + resource <- objectText "resource" entryFields + pure + Source + { sourceId = objectText "id" entryFields, + sourceResource = resource, + sourceTitle = objectText "title" entryFields, + sourceAuthor = parseActor <$> objectText "author" entryFields, + sourceUsageCount = objectInteger "usage_count" entryFields, + sourceLastModified = objectText "last_modified" entryFields, + sourceUsageWindow = usageWindowFromValue =<< KeyMap.lookup (AesonKey.fromText "usage_window") entryFields + } + _ -> Nothing + +-- | Read the document-scope @usage_window@, a sibling of @sources@ rather than +-- a member of it (specification §5.1). +readUsageWindow :: Frontmatter -> Maybe UsageWindow +readUsageWindow frontmatterValue = + usageWindowFromValue =<< frontmatterLookup "usage_window" frontmatterValue + +-- | Resolve which window frames a source's @usage_count@, per §5.1: the entry's +-- own window wins when present, otherwise the document-scope one applies. +-- +-- This is a named function rather than an inlined fallback because it is the +-- one piece of provenance logic a consumer is most likely to get wrong, and +-- every reader of a @usage_count@ must agree on it. +effectiveUsageWindow :: Maybe UsageWindow -> Source -> Maybe UsageWindow +effectiveUsageWindow documentWindow Source {sourceUsageWindow} = + sourceUsageWindow <|> documentWindow + +usageWindowFromValue :: Value -> Maybe UsageWindow +usageWindowFromValue = \case + Object windowFields -> + Just (UsageWindow (objectText "from" windowFields) (objectText "to" windowFields)) + _ -> Nothing + +-- | The one @type@ value that carries the OKF v0.2 computation contract +-- (specification §10.1). +-- +-- Matched as an exact, case-sensitive string. §4.1 says type values are "not +-- registered centrally" and consumers "MUST tolerate unknown types gracefully", +-- so okf keeps no taxonomy of types; but §10.1 names this one explicitly and +-- §10.5 calls @type: Attested Computation@ "a frontmatter signal", so matching +-- that single literal follows the specification rather than inventing a +-- registry. A document saying @attested computation@ gets no contract handling, +-- which is the tolerance §4.1 asks for. +attestedComputationType :: Text +attestedComputationType = "Attested Computation" + +-- | One typed, named hole an agent may fill when running an attested +-- computation (specification §10.2). +-- +-- Binding semantics follow the concept's @runtime@: the same entry is a SQL +-- bind variable under @bigquery@, a var under @dbt@, and a function argument +-- under @python@. That is why @runtime@ is the field §10.2 marks REQUIRED — +-- without it a parameter has no meaning. +-- +-- @parameterType@ and @parameterRequired@ are optional even though §10.2 writes +-- every entry as @{ name, type, required }@: that describes the shape rather +-- than marking the members REQUIRED, and §11 forbids rejecting a document for a +-- malformed optional field. @parameterName@ is not optional, because an entry +-- naming no hole is not a parameter at all. +data Parameter = Parameter + { parameterName :: !Text, + parameterType :: !(Maybe Text), + parameterRequired :: !(Maybe Bool) + } + deriving stock (Generic, Eq, Show) + +-- | How an attested computation is run (specification §10.2). +-- +-- @executorResource@ names run instructions or code that a runner — an agent, +-- or deterministic consumer code — follows. @executorReceipt@ declares the +-- fields a run must return: the evidence the attester inspects, such as a +-- BigQuery @job_id@ and the SQL the job actually executed. +-- +-- okf never runs an executor and never sees a receipt. §10.5 marks the +-- execute-and-attest workflow informative and places its runtime artifacts +-- outside the bundle entirely; this record only says where the instructions +-- live. +data Executor = Executor + { executorResource :: !(Maybe Text), + executorReceipt :: ![Text] + } + deriving stock (Generic, Eq, Show) + +-- | The deterministic check on a run's receipt (specification §10.2). +-- +-- @attesterResource@ names code — explicitly with no language model in it — +-- that takes a receipt and returns a verdict, meant to run consumer-side. okf +-- never runs it and never computes a verdict; see +-- @docs\/adr\/8-derived-not-stored-trust-and-credibility.md@ on what okf +-- declines to derive. +-- +-- A newtype over one field rather than a bare 'Maybe' 'Text', because §12 lists +-- "the attester ABI, portability, and sandboxing" among the items deferred to a +-- future OKF revision. The record will grow; a named type means it grows +-- without changing every call site. +newtype Attester = Attester {attesterResource :: Maybe Text} + deriving stock (Generic, Eq, Show) + +-- | Read the @runtime@ field (specification §10.2): the system that would +-- execute the computation, such as @bigquery@, @postgres@, @dbt@, @python@, or +-- @Looker@. +-- +-- Kept verbatim and never matched against a list of known runtimes. §10.2 gives +-- those five as examples rather than as an enumeration, and a closed set here +-- would reject a correct document naming a runtime okf has not heard of. +-- +-- Like every v0.2 reader this never fails: a non-textual value is simply not +-- read. Reporting a missing @runtime@ on an 'attestedComputationType' concept is +-- 'Okf.Validation.validateDocument''s job. +readRuntime :: Frontmatter -> Maybe Text +readRuntime frontmatterValue = + case frontmatterLookup "runtime" frontmatterValue of + Just (String value) -> Just value + _ -> Nothing + +-- | Read the @parameters@ list (specification §10.2). +-- +-- An entry with no textual @name@ is skipped, exactly as 'readSources' skips an +-- entry with no @resource@: a hole with no name cannot be filled. An absent key, +-- or a value that is not a list, yields @[]@. +-- +-- @required@ is read only from a YAML boolean. The string @"true"@ yields +-- 'Nothing', for the same reason 'objectInteger' refuses a numeric string: +-- coercing it would make the field's type unpredictable and hide a producer +-- mistake. +readParameters :: Frontmatter -> [Parameter] +readParameters frontmatterValue = + case frontmatterLookup "parameters" frontmatterValue of + Just (Array entries) -> foldMap (toList . parameterFromValue) entries + _ -> [] + where + parameterFromValue = \case + Object entryFields -> do + name <- objectText "name" entryFields + pure + Parameter + { parameterName = name, + parameterType = objectText "type" entryFields, + parameterRequired = objectBool "required" entryFields + } + _ -> Nothing + +-- | Read the @computation@ field (specification §10.2): a §6.2 path to a file +-- holding the computation, used instead of an inline body fence. +-- +-- Deliberately returns the raw text and does __not__ resolve the path. Resolving +-- a path-valued frontmatter field against the bundle is +-- 'Okf.Validation.validateBundle''s job, which has the bundle inventory this +-- reader does not; keeping the reader dumb is also what preserves the +-- round-trip property, since a resolved path is not the text the producer wrote. +-- +-- §10.3 makes this key and the body's @# Computation@ fence mutually exclusive. +-- Checking that is body inspection and is not done here. +readComputation :: Frontmatter -> Maybe Text +readComputation frontmatterValue = + case frontmatterLookup "computation" frontmatterValue of + Just (String value) -> Just value + _ -> Nothing + +-- | Read the @executor@ mapping (specification §10.2). +-- +-- Returns 'Nothing' when the key is absent or its value is not a mapping. Unlike +-- 'readGenerated' no member is mandatory, because §10.2 marks none of them +-- REQUIRED: an @executor@ carrying only a @receipt@ still says something a +-- consumer can use. +-- +-- A @receipt@ written as a bare string rather than a list is read as a +-- one-element list, mirroring how §5.2's @verified@ tolerates a bare mapping +-- where a list is expected. A non-textual list element is dropped. +readExecutor :: Frontmatter -> Maybe Executor +readExecutor frontmatterValue = + case frontmatterLookup "executor" frontmatterValue of + Just (Object executorFields) -> + Just + Executor + { executorResource = objectText "resource" executorFields, + executorReceipt = objectTextList "receipt" executorFields + } + _ -> Nothing + +-- | Read the @attester@ mapping (specification §10.2). +-- +-- Returns 'Nothing' when the key is absent or its value is not a mapping. An +-- @attester@ mapping with no @resource@ still reads as an 'Attester' carrying +-- 'Nothing': §10.2 marks no member REQUIRED, and the distinction between "no +-- attester declared" and "an attester declared badly" is one a diagnostic can +-- make only if the reader keeps it. +readAttester :: Frontmatter -> Maybe Attester +readAttester frontmatterValue = + case frontmatterLookup "attester" frontmatterValue of + Just (Object attesterFields) -> Just (Attester (objectText "resource" attesterFields)) + _ -> Nothing + +-- | Where an attested computation's computation actually lives (specification +-- §10.3). +data ComputationSource + = -- | A code block in the body's @# Computation@ section, carrying its literal + -- contents. + ComputationInline !Text + | -- | The §6.2 path in the @computation@ frontmatter key, verbatim and not + -- resolved against the bundle. + ComputationFile !Text + deriving stock (Generic, Eq, Show) + +-- | Every computation the document offers, file before inline. +-- +-- §10.3 requires exactly one — "Inline: a single fenced code block in the body +-- under @# Computation@" or "File: set @computation@ to a path (§6.2) and omit +-- the body fence" — and this reader deliberately does not enforce that. Like +-- every reader in this module it restates what the document says and never +-- fails. A list with none, or with two, is what +-- 'Okf.Validation.validateDocument' reports. +-- +-- This is the first reader here that takes an 'OKFDocument' rather than a +-- 'Frontmatter', because §10.3 is the first rule in OKF that spans both halves +-- of a document: the frontmatter key and the body section are alternatives to +-- each other, so neither half can answer the question alone. +-- +-- Type-agnostic, matching every other projection here: a @# Computation@ +-- section on a @Metric@ is still a fact about that document. Scoping a report to +-- 'attestedComputationType' is "Okf.Validation"'s job. +readComputationSources :: OKFDocument -> [ComputationSource] +readComputationSources OKFDocument {frontmatter = documentFrontmatter, body = documentBody} = + foldMap (pure . ComputationFile) (readComputation documentFrontmatter) + <> map ComputationInline (computationBlocks documentBody) + +-- | Read an integral member. Only a YAML integer qualifies: a numeric string +-- and a fractional number both yield 'Nothing', because aeson's @Integer@ +-- decoder rejects each. Coercing either would make the field's type +-- unpredictable for downstream consumers and would hide a producer mistake. +objectInteger :: Text -> KeyMap.KeyMap Value -> Maybe Integer +objectInteger key members = + case KeyMap.lookup (AesonKey.fromText key) members of + Just value@(Number _) -> + case Aeson.fromJSON value of + Aeson.Success parsed -> Just parsed + Aeson.Error _ -> Nothing + _ -> Nothing + +objectText :: Text -> KeyMap.KeyMap Value -> Maybe Text +objectText key members = + case KeyMap.lookup (AesonKey.fromText key) members of + Just (String value) -> Just value + _ -> Nothing + +-- | Read a boolean member. Only a YAML boolean qualifies; the string @"true"@ +-- yields 'Nothing', for the same reason 'objectInteger' refuses a numeric +-- string. +objectBool :: Text -> KeyMap.KeyMap Value -> Maybe Bool +objectBool key members = + case KeyMap.lookup (AesonKey.fromText key) members of + Just (Bool value) -> Just value + _ -> Nothing + +-- | Read a member that is a list of strings, tolerating a bare string as a +-- one-element list. Non-textual elements are dropped rather than failing, and an +-- absent or otherwise-shaped value yields @[]@ — the same shape 'tagsField' in +-- @Okf.Bundle@ gives @tags@. +objectTextList :: Text -> KeyMap.KeyMap Value -> [Text] +objectTextList key members = + case KeyMap.lookup (AesonKey.fromText key) members of + Just (Array values) -> foldMap textValue (toList values) + Just (String value) -> [value] + _ -> [] + where + textValue = \case + String value -> [value] + _ -> [] + -- | Build frontmatter from a list of @(key, value)@ pairs. Later duplicate -- keys overwrite earlier ones. frontmatterFromFields :: [(Text, Value)] -> Frontmatter @@ -134,10 +642,96 @@ setDescription :: Text -> Frontmatter -> Frontmatter setDescription value = setField "description" (String value) --- | Set the @timestamp@ field. +-- | Set the OKF v0.1 @timestamp@ field. +-- +-- OKF v0.2 supersedes @timestamp@ with @generated.at@ (specification §13.1); +-- 'setGenerated' writes the v0.2 form. This is kept for producers deliberately +-- writing v0.1 bundles, which okf continues to read and write. See +-- @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@. setTimestamp :: Text -> Frontmatter -> Frontmatter setTimestamp value = setField "timestamp" (String value) +-- | Set the OKF v0.2 @generated@ field as a YAML mapping with @by@ and, when +-- present, @at@ (specification §5.2). This is the single place that knows +-- @generated@ is a mapping of an actor and a datetime. +setGenerated :: Generated -> Frontmatter -> Frontmatter +setGenerated Generated {generatedBy, generatedAt} = + setField "generated" (actorMapping generatedBy generatedAt) + +-- | Set the OKF v0.2 @verified@ field (specification §5.2). +-- +-- Always writes a YAML list, even for one entry. §5.2 permits the bare-mapping +-- form on input and 'readVerified' honours that MUST, but writing it would be +-- pointlessly ambiguous when the list is the specification's primary form. +setVerified :: [Verification] -> Frontmatter -> Frontmatter +setVerified verifications = + setField "verified" (Array (Vector.fromList (entryValue <$> verifications))) + where + entryValue Verification {verificationBy, verificationAt} = + actorMapping verificationBy verificationAt + +-- | Set the OKF v0.2 @status@ field (specification §5.4). +setStatus :: Status -> Frontmatter -> Frontmatter +setStatus status = setField "status" (String (renderStatus status)) + +-- | Set the OKF v0.2 @stale_after@ field (specification §5.5). The value is an +-- absolute @YYYY-MM-DD@ date; it is written as given and not validated here. +setStaleAfter :: Text -> Frontmatter -> Frontmatter +setStaleAfter value = setField "stale_after" (String value) + +-- | Set the OKF v0.2 @sources@ field as a YAML list of mappings (§5.1). +-- +-- Every optional key that is 'Nothing' is omitted rather than written as an +-- explicit null, so a round-trip through 'readSources' is lossless and a +-- generated document carries no noise. This is the single place that knows the +-- shape of a source entry. +setSources :: [Source] -> Frontmatter -> Frontmatter +setSources sources = + setField "sources" (Array (Vector.fromList (sourceValue <$> sources))) + where + sourceValue source = + Object + ( KeyMap.fromList + ( concat + [ [(AesonKey.fromText "id", String value) | Just value <- [sourceId source]], + [(AesonKey.fromText "resource", String (sourceResource source))], + [(AesonKey.fromText "title", String value) | Just value <- [sourceTitle source]], + [(AesonKey.fromText "author", String (renderActor value)) | Just value <- [sourceAuthor source]], + [(AesonKey.fromText "usage_count", Number (fromInteger value)) | Just value <- [sourceUsageCount source]], + [(AesonKey.fromText "last_modified", String value) | Just value <- [sourceLastModified source]], + [(AesonKey.fromText "usage_window", usageWindowValue value) | Just value <- [sourceUsageWindow source]] + ] + ) + ) + +-- | Set the document-scope @usage_window@ that frames every @usage_count@ +-- (specification §5.1). +setUsageWindow :: UsageWindow -> Frontmatter -> Frontmatter +setUsageWindow window = setField "usage_window" (usageWindowValue window) + +usageWindowValue :: UsageWindow -> Value +usageWindowValue UsageWindow {usageWindowFrom, usageWindowTo} = + Object + ( KeyMap.fromList + ( concat + [ [(AesonKey.fromText "from", String value) | Just value <- [usageWindowFrom]], + [(AesonKey.fromText "to", String value) | Just value <- [usageWindowTo]] + ] + ) + ) + +-- | A @{ by, at }@ YAML mapping, omitting @at@ when absent. Shared by the +-- @generated@ and @verified@ families, which specification §5.2 gives the same +-- shape. +actorMapping :: Actor -> Maybe Text -> Value +actorMapping actor occurredAt = + Object + ( KeyMap.fromList + ( (AesonKey.fromText "by", String (renderActor actor)) + : [(AesonKey.fromText "at", String atValue) | Just atValue <- [occurredAt]] + ) + ) + -- | Set the @resource@ field. setResource :: Text -> Frontmatter -> Frontmatter setResource value = setField "resource" (String value) @@ -157,9 +751,9 @@ else Right (OKFDocument emptyFrontmatter input) -- | Serialize to a normalized YAML-frontmatter Markdown document. Frontmatter --- keys are emitted in a deterministic order (the six common OKF fields first — --- @type, title, description, timestamp, resource, tags@ — then every other key --- in ascending alphabetical order) so regenerating a bundle yields minimal diffs. +-- keys are emitted in a deterministic order ('coreFrontmatterFieldOrder' first, +-- in that fixed order, then every other key in ascending alphabetical order) so +-- regenerating a bundle yields minimal diffs. serializeDocument :: OKFDocument -> Text serializeDocument OKFDocument {frontmatter, body} = Text.unlines ["---", renderedYaml, "---", ""] <> ensureTrailingNewline body @@ -175,9 +769,9 @@ where config = YamlPretty.setConfCompare (comparing okfKeyRank) YamlPretty.defConfig --- | Sort key for deterministic frontmatter ordering: the six common OKF fields --- come first in their fixed order; every other key sorts after them --- alphabetically by its text form. +-- | Sort key for deterministic frontmatter ordering: the core OKF fields come +-- first in their fixed 'coreFrontmatterFieldOrder'; every other key sorts after +-- them alphabetically by its text form. okfKeyRank :: Text -> (Int, Text) okfKeyRank keyText = case lookup keyText commonRanks of @@ -186,8 +780,103 @@ where commonRanks = zip coreFrontmatterFieldOrder [0 ..] +-- | The deterministic OKF concept-level key order: identity first, then the +-- v0.2 lifecycle field (§5.4), then the v0.2 attested computation contract +-- (§10.2), then the v0.2 trust families (§5.2, §5.5), then the v0.2 provenance +-- family (§5.1), then the v0.1 @timestamp@ superseded by @generated.at@ (§13.1). +-- +-- The five computation keys sit between @status@ and @generated@ because that is +-- where §10.2's own worked example puts them, so a concept copied out of the +-- specification and regenerated by okf comes back in the order its author wrote. +-- They are in this list at all for the reason +-- [ADR 7](docs/adr/7-okf-v0-1-legacy-fallback-policy.md) gives for the six v0.2 +-- concept keys before them: the list "exists to name the keys the format itself +-- defines", §13.2 makes these five format-defined, and leaving them out would +-- make a closed profile (@allowUnknownFields = False@) reject a conformant +-- Attested Computation until its author redeclared five keys they did not +-- choose — "a tax that grows with every specification revision". That they are +-- meaningful for exactly one @type@, unlike every other key here, does not +-- change the answer: closure governs /unknown/ keys, and a key §13.2 names is +-- not unknown. A profile that wants to reject @runtime@ on a @Metric@ says so +-- with a @TypeRule@, which is the layer that knows about types. +-- +-- @okf_version@ is deliberately absent: it is an index-level key that appears +-- only in a bundle-root @index.md@ (§12), never on a concept. coreFrontmatterFieldOrder :: [Text] -coreFrontmatterFieldOrder = ["type", "title", "description", "timestamp", "resource", "tags"] +coreFrontmatterFieldOrder = + [ "type", + "title", + "description", + "resource", + "tags", + "status", + "runtime", + "parameters", + "computation", + "executor", + "attester", + "generated", + "verified", + "stale_after", + "sources", + "usage_window", + "timestamp" + ] + +-- | Concept-level frontmatter keys that OKF v0.2 introduced (specification +-- §13.2), as reference data. +-- +-- __Deliberately not used as a compile-time profile check.__ It is tempting to +-- reject a profile that declares @okfVersion = "0.1"@ and names one of these, +-- and that check was written and then removed. A profile key /name/ does not +-- imply the OKF core key of that name: per +-- @docs\/adr\/1-profile-declared-document-ids.md@, constraining keys the core +-- format does not own is what profiles are /for/, and @status@, @sources@, and +-- @verified@ are ordinary words that teams were already using as house +-- conventions before v0.2 claimed them. Rejecting +-- @field.documented "status" "One of: proposed, accepted, superseded."@ for +-- naming an ADR lifecycle would be a false positive on a pinned descriptor okf +-- cannot see. See @docs\/adr\/11-growing-the-profile-descriptor-language.md@ on +-- retroactive definition errors. +-- +-- 'fieldsSupersededInV02' is checked, because it is the asymmetric case: it +-- fires only when the profile has declared v0.2 or later, which is an opt-in to +-- v0.2 semantics under which the key unambiguously means the core one. +-- +-- Deliberately kept beside 'coreFrontmatterFieldOrder' and deliberately not +-- merged into it. That list answers "which keys does okf own", which is a +-- different question with different consumers — serialization order, and the set +-- of keys a closed profile always permits, per +-- [ADR 7](docs/adr/7-okf-v0-1-legacy-fallback-policy.md). Merging the two would +-- couple a version question to a permission question. +-- +-- A plain @[Text]@ rather than a map to 'Okf.Index.OkfVersion' because +-- @Okf.Index@ imports this module; pairing a key with a version happens in +-- @Okf.Profile@, which imports both. +fieldsIntroducedInV02 :: [Text] +fieldsIntroducedInV02 = + [ "status", + "generated", + "verified", + "stale_after", + "sources", + "usage_window", + -- §13.2's second bullet: "New concept type `Attested Computation` and its + -- computation keys `runtime`, `parameters`, `computation`, `executor`, + -- `attester` (§10)." + "runtime", + "parameters", + "computation", + "executor", + "attester" + ] + +-- | Concept-level frontmatter keys OKF v0.2 superseded (specification §13.1). +-- @timestamp@ is superseded by @generated.at@. okf still /reads/ it, per +-- [ADR 7](docs/adr/7-okf-v0-1-legacy-fallback-policy.md); a profile that +-- /demands/ it while declaring v0.2 is asking authors to write a retired key. +fieldsSupersededInV02 :: [Text] +fieldsSupersededInV02 = ["timestamp"] parseFrontmatterDocument :: ByteString.ByteString -> Either DocumentParseError OKFDocument parseFrontmatterDocument inputBytes = diff --git a/src/Okf/Graph.hs b/src/Okf/Graph.hs --- a/src/Okf/Graph.hs +++ b/src/Okf/Graph.hs @@ -11,7 +11,6 @@ where import CMarkGFM qualified -import Control.Monad (foldM) import Data.Aeson (ToJSON (..), object, (.=)) import Data.List qualified as List import Data.Map.Strict qualified as Map @@ -20,8 +19,9 @@ import Okf.Bundle import Okf.ConceptId import Okf.Document (body) +import Okf.Markdown (markdownOptions) +import Okf.Path (PathReference (..), classifyPathReference) import Okf.Prelude hiding ((.=)) -import System.FilePath (()) import System.FilePath qualified as FilePath -- | A graph node for one concept. @@ -135,28 +135,33 @@ extractMarkdownLinks :: Text -> [Text] extractMarkdownLinks markdown = - walk (CMarkGFM.commonmarkToNode [] [] markdown) + walk (CMarkGFM.commonmarkToNode markdownOptions [] markdown) where walk (CMarkGFM.Node _ nodeType childNodes) = case nodeType of CMarkGFM.LINK url _title -> [url] _ -> foldMap walk childNodes +-- | Resolve one Markdown link destination to the concept it names, if any. +-- +-- The §6.2 grammar lives in 'Okf.Path' and is shared with the profile layer, but +-- this function deliberately differs from it in one place, and the difference is +-- the point of keeping 'isExternalUrl' here. A body link is a heuristic over +-- prose, so only the three schemes a Markdown author plausibly writes are +-- treated as external, and anything that resolves to no concept is dropped in +-- silence — OKF v0.2 §6.1 says a broken body link may be knowledge not yet +-- written. A path-valued /field/ is read the other way round: every scheme is +-- recognized, and one the profile did not permit is reported rather than +-- ignored. resolveLink :: Concept -> Text -> [ConceptId] resolveLink concept rawUrl | isExternalUrl rawUrl = [] - | FilePath.takeExtension cleanPath /= ".md" = [] - | otherwise = maybe [] (either (const []) pure . conceptIdFromFilePath) bundleRelativePath - where - cleanPath = Text.unpack (stripUrlSuffix rawUrl) - sourceDirectory = FilePath.takeDirectory (conceptIdToFilePath (conceptIdOf concept)) - bundleRelativePath - | "/" `Text.isPrefixOf` rawUrl = collapseBundlePath (dropWhile (== '/') cleanPath) - | otherwise = collapseBundlePath (sourceDirectory cleanPath) - -stripUrlSuffix :: Text -> Text -stripUrlSuffix = - Text.takeWhile (\char -> char /= '#' && char /= '?') + | otherwise = + case classifyPathReference (conceptIdOf concept) rawUrl of + BundlePath resolved + | FilePath.takeExtension resolved == ".md" -> + either (const []) pure (conceptIdFromFilePath resolved) + _ -> [] isExternalUrl :: Text -> Bool isExternalUrl rawUrl = @@ -164,13 +169,3 @@ in "http://" `Text.isPrefixOf` lower || "https://" `Text.isPrefixOf` lower || "mailto:" `Text.isPrefixOf` lower - -collapseBundlePath :: FilePath -> Maybe FilePath -collapseBundlePath = - fmap FilePath.joinPath . foldM step [] . FilePath.splitDirectories - where - step [] "." = Just [] - step acc "." = Just acc - step [] ".." = Nothing - step acc ".." = Just (init acc) - step acc segment = Just (acc <> [segment]) diff --git a/src/Okf/Index.hs b/src/Okf/Index.hs --- a/src/Okf/Index.hs +++ b/src/Okf/Index.hs @@ -1,30 +1,158 @@ --- | Deterministic Markdown index rendering for OKF bundle directories. +-- | Deterministic Markdown index rendering for OKF bundle directories, and the +-- bundle-root version declaration of specification §12. module Okf.Index ( renderBundleIndexes, + renderBundleIndexesWith, renderIndex, + renderRootIndex, writeBundleIndexes, + writeBundleIndexesWith, + + -- * OKF version declaration (specification §12) + OkfVersion (..), + VersionDeclaration (..), + readBundleVersion, + parseOkfVersion, + renderOkfVersion, + supportedOkfVersion, ) where +import Control.Exception (IOException, try) +import Data.Aeson.Text qualified as Aeson.Text +import Data.Char qualified as Char import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO +import Data.Text.Lazy qualified as Text.Lazy import Okf.Bundle +import Okf.Document (OKFDocument (..), frontmatterLookup, parseDocument) import Okf.Prelude import System.Directory ( doesDirectoryExist, + doesFileExist, listDirectory, ) import System.FilePath (()) import System.FilePath qualified as FilePath +import System.IO.Error (ioeGetErrorString) +import Text.Read (readMaybe) --- | Render an @index.md@ for one bundle directory from its immediate concepts --- and subdirectory names. -renderIndex :: [FilePath] -> [Concept] -> Text -renderIndex subdirectories concepts = - Text.intercalate "\n" (filter (not . Text.null) [subdirectorySection, conceptSections]) <> "\n" +-- | An OKF format version, written @\.\@ (specification §12). +-- +-- The derived 'Ord' compares major before minor, which is what §12's +-- "a minor version bump introduces backward-compatible additions" needs: a +-- consumer may read any declaration at or below the highest version it +-- understands within the same major. +data OkfVersion = OkfVersion + { okfVersionMajor :: !Int, + okfVersionMinor :: !Int + } + deriving stock (Generic, Eq, Ord, Show) + +-- | What a bundle's root @index.md@ says about the version it targets. +-- +-- All three cases are readable. §12 makes the declaration a MAY, so an absent +-- one is the ordinary case rather than a defect, and a malformed one is worth a +-- strict-authoring diagnostic but never a refusal. +data VersionDeclaration + = VersionDeclared !OkfVersion + | VersionUndeclared + | -- | The key is present but its value is not @\.\@. Carries + -- the value as the author wrote it, so a diagnostic can quote it back. + VersionUnparseable !Text + deriving stock (Generic, Eq, Show) + +-- | The highest OKF version this library understands. Specification §12's +-- best-effort rule is applied against this value: see +-- @Okf.Validation.versionGate@, which is the one place that decides what a +-- declared version implies. +supportedOkfVersion :: OkfVersion +supportedOkfVersion = OkfVersion {okfVersionMajor = 0, okfVersionMinor = 2} + +-- | Render a version back to its @\.\@ text form. +renderOkfVersion :: OkfVersion -> Text +renderOkfVersion OkfVersion {okfVersionMajor, okfVersionMinor} = + Text.pack (show okfVersionMajor) <> "." <> Text.pack (show okfVersionMinor) + +-- | Parse a @\.\@ version. Exactly two dot-separated runs of +-- ASCII digits; anything else is unparseable. +parseOkfVersion :: Text -> Maybe OkfVersion +parseOkfVersion rawVersion = + case Text.splitOn "." (Text.strip rawVersion) of + [majorText, minorText] -> + OkfVersion <$> digits majorText <*> digits minorText + _ -> Nothing where + digits component + | Text.null component = Nothing + | Text.all Char.isDigit component = readMaybe (Text.unpack component) + | otherwise = Nothing + +-- | Read the version a bundle declares in its root @index.md@ frontmatter. +-- +-- §8 permits frontmatter in exactly one @index.md@, the bundle root's, and §12 +-- permits exactly one key in it. This reads that key and nothing else; it does +-- not turn @index.md@ into a concept, which stays reserved by +-- 'Okf.Bundle.isReservedMarkdownFile'. +-- +-- A missing root @index.md@, one with no frontmatter, one whose frontmatter +-- omits the key, and one whose frontmatter does not parse all yield +-- 'VersionUndeclared'. Only a present key with an unreadable value yields +-- 'VersionUnparseable'. The 'Left' is reserved for genuine IO failure. +readBundleVersion :: FilePath -> IO (Either BundleError VersionDeclaration) +readBundleVersion root = do + let indexPath = root "index.md" + exists <- doesFileExist indexPath + if not exists + then pure (Right VersionUndeclared) + else do + loaded <- try (Text.IO.readFile indexPath) + pure $ case loaded of + Left (exception :: IOException) -> + Left (BundleIoError "index.md" (Text.pack (ioeGetErrorString exception))) + Right content -> + Right $ case parseDocument content of + Left _ -> VersionUndeclared + Right OKFDocument {frontmatter} -> + case frontmatterLookup "okf_version" frontmatter of + Nothing -> VersionUndeclared + Just value -> declarationFromValue value + +-- | Read the declared value, accepting both the quoted string form the +-- specification writes (@okf_version: "0.2"@) and the bare YAML number a +-- careless author writes (@okf_version: 0.2@). A bundle should not become +-- unreadable over a missing pair of quotes. +declarationFromValue :: Value -> VersionDeclaration +declarationFromValue value = + case parseOkfVersion rendered of + Just version -> VersionDeclared version + Nothing -> VersionUnparseable rendered + where + rendered = case value of + String text -> text + -- Everything else is quoted back through JSON so the diagnostic can show + -- what was written. A YAML number reaches here as @0.2@, which parses. + other -> Text.Lazy.toStrict (Aeson.Text.encodeToLazyText other) + +-- | Render an @index.md@ for one bundle directory from its immediate concepts, +-- subdirectory names, and non-concept files. +-- +-- Specification §8 says an index "enumerates the directory's contents to support +-- progressive disclosure". A directory holding only +-- @references\/attesters\/revenue.py@ has contents, and before the files +-- parameter existed its generated index was a single newline — which is exactly +-- the directory shape §6.3's @references\/@ convention encourages. See +-- @docs\/adr\/13-the-references-convention-and-non-markdown-files.md@. +-- +-- The files given are those that are not concepts and not reserved: in practice +-- every regular file whose extension is not @.md@. Dotfiles are excluded by the +-- caller, so a stray @.DS_Store@ never reaches a committed index. +renderIndex :: [FilePath] -> [FilePath] -> [Concept] -> Text +renderIndex subdirectories files concepts = + Text.intercalate "\n" (filter (not . Text.null) [subdirectorySection, fileSection, conceptSections]) <> "\n" + where sortedSubdirectories = List.sort subdirectories subdirectorySection | null sortedSubdirectories = "" @@ -35,6 +163,11 @@ : (directoryBullet <$> sortedSubdirectories) ) + sortedFiles = List.sort files + fileSection + | null sortedFiles = "" + | otherwise = Text.unlines ("# Files" : "" : (fileBullet <$> sortedFiles)) + groupedConcepts = Map.toAscList (foldr addConcept Map.empty concepts) conceptSections = Text.intercalate "\n" (sectionForType <$> groupedConcepts) @@ -51,10 +184,41 @@ : (conceptBullet <$> List.sortOn conceptSourcePath concepts) ) +-- | Render the bundle-root @index.md@, which is the one index permitted to +-- carry frontmatter (specification §8) and the one place a bundle declares the +-- version it targets (§12). +-- +-- With no version this is exactly 'renderIndex', so a bundle that declares +-- nothing keeps a frontmatter-free root index. The value is quoted because §12 +-- writes it quoted and because an unquoted @0.2@ is a YAML float whose text +-- form no serializer guarantees to preserve. +renderRootIndex :: Maybe OkfVersion -> [FilePath] -> [FilePath] -> [Concept] -> Text +renderRootIndex version = renderRootIndexText (renderOkfVersion <$> version) + +-- | 'renderRootIndex' over the declaration's raw text rather than a parsed +-- version, so that a declaration okf cannot parse survives regeneration +-- verbatim instead of being deleted. +renderRootIndexText :: Maybe Text -> [FilePath] -> [FilePath] -> [Concept] -> Text +renderRootIndexText Nothing subdirectories files concepts = + renderIndex subdirectories files concepts +renderRootIndexText (Just versionText) subdirectories files concepts = + Text.unlines ["---", "okf_version: \"" <> escaped versionText <> "\"", "---", ""] + <> renderIndex subdirectories files concepts + where + -- The only two characters that can end a double-quoted YAML scalar early. + -- A parsed version can contain neither; a preserved raw one might. + escaped = Text.replace "\"" "\\\"" . Text.replace "\\" "\\\\" + directoryBullet :: FilePath -> Text directoryBullet directory = "- [" <> Text.pack directory <> "/](" <> Text.pack directory <> "/index.md)" +-- | A file has no frontmatter, so there is no title to prefer and no description +-- to append: the link text is the name. +fileBullet :: FilePath -> Text +fileBullet file = + "- [" <> Text.pack file <> "](" <> Text.pack file <> ")" + conceptBullet :: Concept -> Text conceptBullet concept = "- [" @@ -64,26 +228,56 @@ <> ")" <> maybe "" (" - " <>) (conceptDescription concept) --- | Write deterministic @index.md@ files for every directory in a bundle. +-- | Write deterministic @index.md@ files for every directory in a bundle, +-- preserving any version declaration the root index already carries. writeBundleIndexes :: FilePath -> IO (Either BundleError ()) -writeBundleIndexes root = do - rendered <- renderBundleIndexes root +writeBundleIndexes = writeBundleIndexesWith Nothing + +-- | 'writeBundleIndexes' with an explicit version declaration for the bundle +-- root. 'Just' overrides whatever the root index carries; 'Nothing' preserves +-- it. +writeBundleIndexesWith :: Maybe OkfVersion -> FilePath -> IO (Either BundleError ()) +writeBundleIndexesWith override root = do + rendered <- renderBundleIndexesWith override root case rendered of Left bundleError -> pure (Left bundleError) Right indexes -> do mapM_ (\(relativePath, content) -> Text.IO.writeFile (root relativePath) content) indexes pure (Right ()) --- | Render every @index.md@ file that would be written for a bundle. +-- | Render every @index.md@ file that would be written for a bundle, +-- preserving any version declaration the root index already carries. renderBundleIndexes :: FilePath -> IO (Either BundleError [(FilePath, Text)]) -renderBundleIndexes root = do +renderBundleIndexes = renderBundleIndexesWith Nothing + +-- | 'renderBundleIndexes' with an explicit version declaration for the bundle +-- root. 'Just' overrides whatever the root index carries; 'Nothing' preserves +-- it. +-- +-- Preserving is not a nicety. Index generation rewrites every directory's +-- @index.md@, root included, so without reading the existing declaration first +-- a single @okf index --write@ would silently delete the bundle's §12 version +-- declaration. +renderBundleIndexesWith :: Maybe OkfVersion -> FilePath -> IO (Either BundleError [(FilePath, Text)]) +renderBundleIndexesWith override root = do walked <- walkBundle root - case walked of + declared <- readBundleVersion root + case (,) <$> walked <*> declared of Left bundleError -> pure (Left bundleError) - Right concepts -> do + Right (concepts, declaration) -> do + let rootVersion = (renderOkfVersion <$> override) <|> declaredText declaration directories <- indexDirectories root concepts - indexes <- mapM (renderDirectoryIndex root concepts) directories + indexes <- mapM (renderDirectoryIndex rootVersion root concepts) directories pure (Right indexes) + where + declaredText = \case + VersionDeclared version -> Just (renderOkfVersion version) + -- An unparseable declaration is preserved as written and left for + -- validation to report. Rewriting it to a version okf invented would + -- destroy the author's text; dropping it would be exactly the data loss + -- this function exists to prevent. + VersionUnparseable rawVersion -> Just rawVersion + VersionUndeclared -> Nothing indexDirectories :: FilePath -> [Concept] -> IO [FilePath] indexDirectories root concepts = do @@ -106,15 +300,21 @@ ) entries -renderDirectoryIndex :: FilePath -> [Concept] -> FilePath -> IO (FilePath, Text) -renderDirectoryIndex root concepts relativeDir = do +-- | Render one directory's index. The bundle root reaches this twice, once as +-- @\"\"@ and once as @\".\"@, and both normalise to the same @index.md@; only +-- the root carries the version declaration. +renderDirectoryIndex :: Maybe Text -> FilePath -> [Concept] -> FilePath -> IO (FilePath, Text) +renderDirectoryIndex rootVersion root concepts relativeDir = do subdirectories <- immediateSubdirectories root relativeDir + files <- immediateFiles root relativeDir let immediateConcepts = List.filter (\concept -> FilePath.normalise (FilePath.takeDirectory (conceptSourcePath concept)) == FilePath.normalise relativeDir) concepts indexPath = relativeDir "index.md" - pure (FilePath.normalise indexPath, renderIndex subdirectories immediateConcepts) + isBundleRoot = FilePath.normalise indexPath == "index.md" + renderFor = if isBundleRoot then renderRootIndexText rootVersion else renderIndex + pure (FilePath.normalise indexPath, renderFor subdirectories files immediateConcepts) immediateSubdirectories :: FilePath -> FilePath -> IO [FilePath] immediateSubdirectories root relativeDir = do @@ -124,5 +324,27 @@ ( \entry -> do isDirectory <- doesDirectoryExist (root relativeDir entry) pure [entry | isDirectory] + ) + entries + +-- | The directory's immediate non-concept files, for the @# Files@ section. +-- +-- Every @.md@ file is excluded rather than only the concepts: a concept has its +-- own typed section and @index.md@ and @log.md@ are reserved, so listing any of +-- the three here would duplicate or clutter. A name beginning with @.@ is +-- skipped so a stray @.DS_Store@ never lands in a committed index. +immediateFiles :: FilePath -> FilePath -> IO [FilePath] +immediateFiles root relativeDir = do + entries <- List.sort <$> listDirectory (root relativeDir) + fmap concat $ + mapM + ( \entry -> do + isDirectory <- doesDirectoryExist (root relativeDir entry) + pure + [ entry + | not isDirectory, + FilePath.takeExtension entry /= ".md", + not ("." `List.isPrefixOf` entry) + ] ) entries diff --git a/src/Okf/Log.hs b/src/Okf/Log.hs --- a/src/Okf/Log.hs +++ b/src/Okf/Log.hs @@ -17,6 +17,7 @@ import Data.Char qualified as Char import Data.Text qualified as Text import Data.Time (Day, defaultTimeLocale, parseTimeM) +import Okf.Markdown (markdownOptions) import Okf.Prelude -- | One parsed @log.md@ file. @@ -58,7 +59,7 @@ finish (foldl' step emptyBuild topLevelNodes) where topLevelNodes = - case CMarkGFM.commonmarkToNode [] [] markdown of + case CMarkGFM.commonmarkToNode markdownOptions [] markdown of CMarkGFM.Node _ _ documentChildren -> documentChildren -- | Render a log deterministically with a trailing newline. diff --git a/src/Okf/Markdown.hs b/src/Okf/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Markdown.hs @@ -0,0 +1,255 @@ +-- | The CommonMark configuration okf parses every body with, footnote label +-- extraction for OKF v0.2 per-claim attribution, and the @# Computation@ body +-- section of an OKF v0.2 attested computation. +module Okf.Markdown + ( markdownOptions, + FootnoteLabels (..), + extractFootnoteLabels, + footnoteLabelsUsed, + computationBlocks, + ) +where + +import CMarkGFM qualified +import Control.Monad (guard) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Word (Word8) +import Okf.Prelude + +-- | The CommonMark options okf parses every body with. +-- +-- Footnotes are enabled because specification §5.1 attributes a claim with a +-- markdown footnote whose label is a @sources[].id@, so footnote syntax must +-- parse as a footnote rather than as prose. Leaving them off is not neutral: a +-- single-token definition such as @[^src]: doc@ is otherwise read as a +-- CommonMark /link reference definition/ with destination @doc@, which turns its +-- citation into a phantom link that "Okf.Graph" extracts and validation then +-- reports as dangling. +-- +-- The cost, accepted deliberately, is that cmark-gfm deletes a footnote +-- definition nothing cites, so Markdown links inside such a definition no longer +-- reach the concept graph. +-- +-- Extensions stay per call site. They are not uniform: @schemaSectionColumns@ in +-- "Okf.Profile" needs @extTable@ to read a GitHub-flavored table, and the other +-- call sites read neither tables nor any other extension construct. +markdownOptions :: [CMarkGFM.CMarkOption] +markdownOptions = [CMarkGFM.optFootnotes] + +-- | The literal contents of every code block in the first @# Computation@ +-- section of a body, in document order. +-- +-- A /section/ runs from a heading whose text is @computation@, trimmed and +-- compared case-insensitively, to the next heading at the same or a shallower +-- level, or to the end of the document. CommonMark makes every heading and block +-- a sibling, so the boundary is drawn here rather than read off the tree. +-- @schemaSectionColumns@ in "Okf.Profile" is the neighbouring inspector and does +-- /not/ bound its section, which is tolerable for asking whether a schema table +-- exists and is not tolerable here: specification §10.3 counts computations, and +-- a fenced block under a later @# Notes@ heading is not a second one. +-- +-- Both spellings of a code block count. Specification §10.3 says "a single +-- fenced code block" and §10.2's own worked example writes an indented one; +-- cmark-gfm reports both as @CODE_BLOCK@ and the tolerant reading is the only +-- one that does not report the specification's own example as broken. +-- +-- Unlike 'extractFootnoteLabels' this reads the parse tree rather than the +-- source text, and that is deliberate rather than an oversight of +-- @docs\/adr\/9-one-markdown-parse-configuration-and-source-scanned-authoring-checks.md@. +-- That record's rule is that a check catching an author's /mistake/ must read +-- what the author wrote, because the tree erases unresolvable syntax. "Is there +-- a code block under this heading" is a question about structure, which is +-- exactly what the tree records. The one erasure that reaches this function is +-- the ADR's accepted cost: a code block inside a footnote definition nothing +-- cites is deleted along with its definition, so it is invisible here. +computationBlocks :: Text -> [Text] +computationBlocks markdown = + let CMarkGFM.Node _ _ topLevel = CMarkGFM.commonmarkToNode markdownOptions [] markdown + in case dropWhile (not . isComputationHeading) topLevel of + (CMarkGFM.Node _ (CMarkGFM.HEADING level) _ : rest) -> + codeBlockLiterals (takeWhile (not . closesSection level) rest) + _ -> [] + where + isComputationHeading (CMarkGFM.Node _ (CMarkGFM.HEADING _) inner) = + Text.toLower (Text.strip (inlineText inner)) == "computation" + isComputationHeading _ = False + + -- A smaller level is a shallower heading, so @## @ inside a @# @ section + -- keeps the section open and the next @# @ closes it. + closesSection level (CMarkGFM.Node _ (CMarkGFM.HEADING other) _) = other <= level + closesSection _ _ = False + + codeBlockLiterals nodes = + [literal | CMarkGFM.Node _ (CMarkGFM.CODE_BLOCK _ literal) _ <- nodes] + +-- | Concatenate all @TEXT@ and @CODE@ literals under a node list, recursively. +inlineText :: [CMarkGFM.Node] -> Text +inlineText = foldMap go + where + go (CMarkGFM.Node _ (CMarkGFM.TEXT literal) _) = literal + go (CMarkGFM.Node _ (CMarkGFM.CODE literal) _) = literal + go (CMarkGFM.Node _ _ inner) = inlineText inner + +-- | The footnote labels a concept body uses, split by how it uses them. +-- +-- A body may cite @[^x]@ without defining it, or define @[^x]:@ without citing +-- it, and the two mean different things to an author. For attribution both count +-- as "this document names source @x@", which is what 'footnoteLabelsUsed' +-- returns. +-- +-- Labels appear in document order with duplicates removed, so that diagnostics +-- built from them are deterministic. +data FootnoteLabels = FootnoteLabels + { footnoteReferences :: ![Text], + footnoteDefinitions :: ![Text] + } + deriving stock (Generic, Eq, Show) + +-- | Every label the body uses, references and definitions together, in document +-- order with duplicates removed. +footnoteLabelsUsed :: FootnoteLabels -> [Text] +footnoteLabelsUsed FootnoteLabels {footnoteReferences, footnoteDefinitions} = + List.nub (footnoteReferences <> footnoteDefinitions) + +-- | Extract footnote labels from a concept body. +-- +-- This reads the body's __source text__ and uses the parse tree only to find the +-- regions that are code. It does not walk the tree for footnote nodes, and that +-- is deliberate rather than a shortcut: cmark-gfm reverts a citation with no +-- matching definition to plain text and deletes a definition nothing cites, so +-- the tree exposes only labels that are already internally consistent. The two +-- mistakes attribution checking exists to catch — a mistyped citation and an +-- uncited definition — are exactly the two the tree erases. +-- +-- Scanning source text alone would match footnote syntax inside code, so the +-- parse supplies the exclusions. One narrow gap follows from parsing with +-- footnotes enabled: a fenced code block nested inside a footnote definition +-- that nothing cites is deleted along with its definition, so text inside it is +-- scanned. That costs a spurious label in a document that already has an uncited +-- definition. +extractFootnoteLabels :: Text -> FootnoteLabels +extractFootnoteLabels markdown = + FootnoteLabels + { footnoteReferences = List.nub (foldMap fst scanned), + footnoteDefinitions = List.nub (foldMap snd scanned) + } + where + scanned = zipWith scanLine [1 ..] (Text.lines markdown) + isCode = codeRegionTest markdown + + scanLine lineNumber lineText = + let bytes = Text.Encoding.encodeUtf8 lineText + inCode = isCode lineNumber + in case definitionAt bytes of + Just (label, afterColon) + | not (inCode (indentColumn bytes)) -> + (references inCode bytes afterColon, [label]) + _ -> (references inCode bytes 0, []) + +-- | The 1-based byte column at which a line's content starts. +indentColumn :: ByteString -> Int +indentColumn bytes = + ByteString.length (ByteString.Char8.takeWhile (== ' ') bytes) + 1 + +-- | A footnote definition opens a line: at most three spaces of indentation, +-- then @[^label]:@. Returns the label and the byte offset just past the colon, +-- so the rest of the line can still be scanned for citations. +definitionAt :: ByteString -> Maybe (Text, Int) +definitionAt bytes = do + let indent = indentColumn bytes - 1 + guard (indent <= 3) + (label, afterBracket) <- labelAt bytes indent + guard (ByteString.indexMaybe bytes afterBracket == Just colon) + pure (label, afterBracket + 1) + +-- | Every @[^label]@ citation on one line from the given byte offset onwards, +-- skipping any that falls inside code and any that is backslash-escaped. +references :: (Int -> Bool) -> ByteString -> Int -> [Text] +references inCode bytes = go + where + go offset = + case ByteString.Char8.elemIndex '[' (ByteString.drop offset bytes) of + Nothing -> [] + Just relative -> + let start = offset + relative + in case labelAt bytes start of + Just (label, afterBracket) + | not (escapedAt start), + not (inCode (start + 1)) -> + label : go afterBracket + Just (_, afterBracket) -> go afterBracket + Nothing -> go (start + 1) + + escapedAt start = + start > 0 && ByteString.indexMaybe bytes (start - 1) == Just backslash + +-- | Match @[^label]@ starting at a byte offset, returning the label and the +-- offset just past the closing bracket. +-- +-- A label is one or more bytes that are none of whitespace, @[@, or @]@, which +-- is close enough to cmark-gfm's own rule for this purpose: the parser rejects +-- @[^has space]@ as a footnote and so does this. +labelAt :: ByteString -> Int -> Maybe (Text, Int) +labelAt bytes start = do + guard (ByteString.indexMaybe bytes start == Just openBracket) + guard (ByteString.indexMaybe bytes (start + 1) == Just caret) + let label = ByteString.takeWhile isLabelByte (ByteString.drop (start + 2) bytes) + afterLabel = start + 2 + ByteString.length label + guard (not (ByteString.null label)) + guard (ByteString.indexMaybe bytes afterLabel == Just closeBracket) + pure (Text.Encoding.decodeUtf8Lenient label, afterLabel + 1) + where + isLabelByte byte = + byte /= openBracket + && byte /= closeBracket + && byte > 32 + && byte /= 127 + +openBracket, closeBracket, caret, colon, backslash :: Word8 +openBracket = 91 +closeBracket = 93 +caret = 94 +colon = 58 +backslash = 92 + +-- | A region of a body that must not be scanned for footnote syntax. +data CodeRegion + = -- | A code block, excluded by whole lines: its start and end line. + CodeLines !Int !Int + | -- | An inline code span, excluded by position: its start and end + -- @(line, column)@. + CodeSpan !(Int, Int) !(Int, Int) + deriving stock (Generic, Eq, Show) + +-- | Whether a @(line, column)@ position falls inside code. +-- +-- Columns are __byte__ offsets into the line, 1-based, because that is what +-- cmark-gfm's position information reports: a line containing any multi-byte +-- character puts its later nodes at a column beyond its character count. +codeRegionTest :: Text -> (Int -> Int -> Bool) +codeRegionTest markdown = \lineNumber column -> + any (covers lineNumber column) regions + where + regions = collect (CMarkGFM.commonmarkToNode markdownOptions [] markdown) + + collect (CMarkGFM.Node nodePosition nodeType childNodes) = + case (nodeType, nodePosition) of + (CMarkGFM.CODE_BLOCK _ _, Just posInfo) -> + [CodeLines (CMarkGFM.startLine posInfo) (CMarkGFM.endLine posInfo)] + (CMarkGFM.CODE _, Just posInfo) -> + [ CodeSpan + (CMarkGFM.startLine posInfo, CMarkGFM.startColumn posInfo) + (CMarkGFM.endLine posInfo, CMarkGFM.endColumn posInfo) + ] + _ -> foldMap collect childNodes + + covers lineNumber column = \case + CodeLines firstLine lastLine -> + lineNumber >= firstLine && lineNumber <= lastLine + CodeSpan spanStart spanEnd -> + (lineNumber, column) >= spanStart && (lineNumber, column) <= spanEnd diff --git a/src/Okf/Path.hs b/src/Okf/Path.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Path.hs @@ -0,0 +1,141 @@ +-- | The OKF v0.2 path-valued field grammar (specification §6.2). +-- +-- Several frontmatter fields name a path or URI: @resource@, +-- @sources[].resource@, and the attested-computation fields @computation@, +-- @executor.resource@, and @attester.resource@. Each accepts an absolute URL, a +-- bundle-relative path beginning with @\/@, or an ordinary relative path. +-- +-- Classification is total and offline: it never touches the filesystem and never +-- decides whether a target exists. Deciding that is the caller's job, because +-- what counts as existing depends on what the caller can see. 'Okf.Profile' +-- resolves only @.md@ targets, because it is handed a list of concepts and +-- nothing else. +-- +-- Deliberately distinct from 'Okf.Graph.extractConceptLinks', which reads +-- Markdown links out of a concept /body/ and is free to drop anything it does +-- not recognize. A path-valued /field/ is something the author wrote on purpose, +-- so every shape it can take is named here rather than silently ignored. +module Okf.Path + ( PathReference (..), + classifyPathReference, + collapseBundlePath, + PathResolution (..), + resolvePathReference, + ) +where + +import Control.Monad (foldM) +import Data.Text qualified as Text +import Network.URI (parseURI, uriScheme) +import Okf.ConceptId (ConceptId, conceptIdToFilePath) +import Okf.Prelude +import System.FilePath (()) +import System.FilePath qualified as FilePath + +-- | What one raw path-valued frontmatter value turned out to be. +data PathReference + = -- | An absolute URL, carrying its case-folded scheme. + ExternalUrl !Text + | -- | A path inside the bundle, collapsed and expressed relative to the + -- bundle root, with any fragment or query suffix removed. + BundlePath !FilePath + | -- | A relative path that climbs above the bundle root. + EscapesBundle + | -- | Text that is neither: empty, whitespace, or otherwise unusable. + MalformedPath + deriving stock (Generic, Eq, Ord, Show) + +-- | Classify one raw value written on the given concept. A relative path is +-- resolved against the concept's own directory, matching how a Markdown link in +-- that concept's body resolves; a value beginning with @\/@ resolves from the +-- bundle root regardless of where the concept lives. +-- +-- An absolute URL is recognized by having a URI scheme, so this accepts every +-- scheme rather than the three 'Okf.Graph' treats as external. Whether a given +-- scheme is /permitted/ is a profile question and is decided by the caller. +classifyPathReference :: ConceptId -> Text -> PathReference +classifyPathReference sourceConcept rawValue + | Text.null trimmed = MalformedPath + | Just scheme <- absoluteUrlScheme trimmed = ExternalUrl scheme + | Text.null cleanText = MalformedPath + | otherwise = + case collapseBundlePath candidatePath of + Nothing -> EscapesBundle + Just [] -> MalformedPath + Just collapsed -> BundlePath collapsed + where + trimmed = Text.strip rawValue + cleanText = stripUrlSuffix trimmed + cleanPath = Text.unpack cleanText + sourceDirectory = FilePath.takeDirectory (conceptIdToFilePath sourceConcept) + candidatePath + | "/" `Text.isPrefixOf` cleanText = dropWhile (== '/') cleanPath + | otherwise = sourceDirectory cleanPath + +-- | The outcome of resolving a path-valued frontmatter field against a bundle: +-- 'classifyPathReference' plus the one question it deliberately does not answer. +data PathResolution + = -- | An absolute URL, carrying its case-folded scheme. okf never fetches it, + -- so this is as resolved as an external target gets. + ResolvedExternal !Text + | -- | Names a file the bundle contains, at the given bundle-relative path. + ResolvedInBundle !FilePath + | -- | Looks exactly like a bundle path, and the bundle holds no such file. + DanglingInBundle !FilePath + | -- | Climbs above the bundle root, so there is nothing in the bundle it + -- could name. + UnresolvableEscape + | -- | Empty, whitespace, or otherwise unusable as either a URL or a path. + UnresolvableMalformed + deriving stock (Generic, Eq, Ord, Show) + +-- | Resolve one raw path-valued value written on the given concept, asking the +-- supplied predicate whether a bundle-relative path names a file that exists. +-- +-- The predicate is a plain function rather than a bundle type so that this +-- module stays below 'Okf.Bundle' in the import graph; a caller holding a +-- 'Okf.Bundle.BundleInventory' passes +-- @flip Okf.Bundle.bundleInventoryMember inventory@. +-- +-- Deliberately a thin composition over 'classifyPathReference'. Its value is +-- that the five outcomes are named once, so every caller agrees on what they +-- mean — in particular that an external URL is /resolved/ rather than skipped, +-- and that a path which escapes the bundle is a different finding from one that +-- simply is not there. +resolvePathReference :: (FilePath -> Bool) -> ConceptId -> Text -> PathResolution +resolvePathReference exists sourceConcept rawValue = + case classifyPathReference sourceConcept rawValue of + ExternalUrl scheme -> ResolvedExternal scheme + BundlePath target + | exists target -> ResolvedInBundle target + | otherwise -> DanglingInBundle target + EscapesBundle -> UnresolvableEscape + MalformedPath -> UnresolvableMalformed + +-- | The case-folded scheme of an absolute URL, or 'Nothing' for anything that +-- is not one. A bundle-absolute path such as @\/references\/policy.md@ has no +-- scheme and so is never mistaken for a URL. +absoluteUrlScheme :: Text -> Maybe Text +absoluteUrlScheme rawValue = do + parsed <- parseURI (Text.unpack rawValue) + let scheme = Text.toCaseFold (Text.dropWhileEnd (== ':') (Text.pack (uriScheme parsed))) + if Text.null scheme then Nothing else Just scheme + +-- | Fold @.@ and @..@ segments, returning 'Nothing' for a path that climbs above +-- the bundle root. Exported because resolving a bundle-relative path is the same +-- operation wherever it is done, and a second copy would be free to drift. +collapseBundlePath :: FilePath -> Maybe FilePath +collapseBundlePath = + fmap FilePath.joinPath . foldM step [] . FilePath.splitDirectories + where + step [] "." = Just [] + step acc "." = Just acc + step [] ".." = Nothing + step acc ".." = Just (init acc) + step acc segment = Just (acc <> [segment]) + +-- | Drop a URL fragment or query suffix, so @policy.md#section@ resolves to the +-- same target as @policy.md@. +stripUrlSuffix :: Text -> Text +stripUrlSuffix = + Text.takeWhile (\character -> character /= '#' && character /= '?') diff --git a/src/Okf/Profile.hs b/src/Okf/Profile.hs --- a/src/Okf/Profile.hs +++ b/src/Okf/Profile.hs @@ -15,2486 +15,3909 @@ FrontmatterRules (..), FieldCondition (..), HandleReferenceRule (..), - FieldRule (..), - NestedRules (..), - NestedFieldRule (..), - Cardinality (..), - FieldFormat (..), - TypeRule (..), - FieldPath (..), - FieldPathSegment (..), - loadProfileFile, - decodeProfileExpr, - profileFieldDescription, - CompiledProfile, - ProfileDefinitionError (..), - compileProfile, - compiledProfileSpec, - profileFieldDescriptionForType, - - -- * Validation - DocumentId (..), - parseDocumentId, - renderDocumentId, - documentIdsInBundle, - nextDocumentId, - ProfileViolation (..), - validateProfile, - - -- * Body inspection - schemaSectionColumns, - ) -where - -import CMarkGFM qualified -import Control.Exception (SomeException, catch) -import Data.Aeson (ToJSON (..), object, (.=)) -import Data.Aeson.Key qualified as Aeson.Key -import Data.Aeson.KeyMap qualified as Aeson.KeyMap -import Data.Char (isAsciiLower, isAsciiUpper) -import Data.List qualified as List -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Text.Read qualified as Text.Read -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime) -import Data.Time.Format.ISO8601 (iso8601ParseM) -import Data.Vector qualified as Vector -import Data.Void (Void) -import Dhall (FromDhall (..), auto, genericAutoWith) -import Dhall qualified -import Dhall.Core (Expr) -import Dhall.Src (Src) -import Network.URI (parseURI, uriScheme) -import Numeric.Natural (Natural) -import Okf.Bundle - ( Concept, - conceptDocument, - conceptIdOf, - conceptResource, - conceptType, - ) -import Okf.ConceptId (ConceptId, renderConceptId) -import Okf.Document (Frontmatter, coreFrontmatterFields, frontmatterKeys, frontmatterLookup) -import Okf.Prelude hiding (List, (.=)) -import Okf.Validation (ValidationProfile (..)) -import "generic-lens" Data.Generics.Labels () - --- | A complete house profile. @description@ is prose documenting the profile as --- a whole; like every description in this module it is never checked against a --- bundle and can never produce a 'ProfileViolation'. -data ProfileSpec = ProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !FrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![TypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | Frontmatter keys the profile expects on every concept. @required@ is always --- checked, @recommended@ only under 'StrictAuthoring', and @optional@ never: --- an optional key is fully validated whenever it is present and its absence is --- never a deviation in any mode. -data FrontmatterRules = FrontmatterRules - { required :: ![FieldRule], - recommended :: ![FieldRule], - optional :: ![FieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | A same-scope predicate controlling whether a field's presence rule applies. --- The source field must compile to a closed scalar textual vocabulary. -data FieldCondition = FieldCondition - { field :: !Text, - hasValue :: ![Text] - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass (FromDhall) - --- | A top-level field whose textual values point either to a local document --- handle with one prefix or to an absolute URI with an explicitly allowed --- scheme. External targets are never resolved by okf. -data HandleReferenceRule = HandleReferenceRule - { localPrefix :: !Text, - externalUriSchemes :: ![Text], - allowSelf :: !Bool - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass (FromDhall) - --- | One documented frontmatter key. The description is prose for humans and is --- never checked against a bundle. -data FieldRule = FieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - elementFields :: !(Maybe NestedRules), - reference :: !(Maybe HandleReferenceRule), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | Rules for the flat object stored in each element of a list-valued field. --- The nested rule type has no @elementFields@ member, which makes the public --- descriptor depth-bounded rather than recursive. -data NestedRules = NestedRules - { required :: ![NestedFieldRule], - recommended :: ![NestedFieldRule], - optional :: ![NestedFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedFieldRule = NestedFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data Cardinality = Any | Scalar | List - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass (FromDhall) - --- | A named textual format. Formats constrain present text values but do not --- imply that a field must be present. -data FieldFormat - = Rfc3339Utc - | Date - | Uri - | UriWithScheme Text - | DocumentHandle Text - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass (FromDhall) - --- | One rule per allowed concept @type@ string. -data TypeRule = TypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !FrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - --- | Decode @type_@ from the Dhall field @type@ by stripping the trailing --- underscore; all other fields map by their exact name. (Mirrors how --- 'Okf.Bundle' uses a @type_@ field to avoid clashing with the @type@ keyword.) -instance FromDhall TypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | Encode a profile so tooling can consume the same descriptor okf reads. --- Written by hand rather than derived so the key order is stable and, more --- importantly, so 'TypeRule' emits @type@ rather than the Haskell field name --- @type_@ — matching the Dhall field and how 'Okf.Graph.Node' already encodes. -instance ToJSON ProfileSpec where - toJSON ProfileSpec {name, description, okfVersion, frontmatter, allowUnknownTypes, allowUnknownFields, idField, types = typeRules} = - object - [ "name" .= name, - "description" .= description, - "okfVersion" .= okfVersion, - "allowUnknownTypes" .= allowUnknownTypes, - "allowUnknownFields" .= allowUnknownFields, - "idField" .= idField, - "frontmatter" .= frontmatter, - "types" .= typeRules - ] - -instance ToJSON FrontmatterRules where - toJSON FrontmatterRules {required, recommended, optional} = - object - [ "required" .= required, - "recommended" .= recommended, - "optional" .= optional - ] - -instance ToJSON FieldCondition where - toJSON FieldCondition {field = fieldName, hasValue} = - object - [ "field" .= fieldName, - "hasValue" .= hasValue - ] - -instance ToJSON HandleReferenceRule where - toJSON HandleReferenceRule {localPrefix, externalUriSchemes, allowSelf} = - object - [ "localPrefix" .= localPrefix, - "externalUriSchemes" .= externalUriSchemes, - "allowSelf" .= allowSelf - ] - -instance ToJSON FieldRule where - toJSON FieldRule {field = fieldName, description, allowedValues, cardinality, format, elementFields, reference, when = condition} = - object - [ "field" .= fieldName, - "description" .= description, - "allowedValues" .= allowedValues, - "cardinality" .= cardinality, - "format" .= format, - "elementFields" .= elementFields, - "reference" .= reference, - "when" .= condition - ] - -instance ToJSON NestedRules where - toJSON NestedRules {required, recommended, optional} = - object - [ "required" .= required, - "recommended" .= recommended, - "optional" .= optional - ] - -instance ToJSON NestedFieldRule where - toJSON NestedFieldRule {field = fieldName, description, allowedValues, cardinality, format, when = condition} = - object - [ "field" .= fieldName, - "description" .= description, - "allowedValues" .= allowedValues, - "cardinality" .= cardinality, - "format" .= format, - "when" .= condition - ] - -instance ToJSON Cardinality where - toJSON = String . cardinalityName - -cardinalityName :: Cardinality -> Text -cardinalityName = \case - Any -> "any" - Scalar -> "scalar" - List -> "list" - -instance ToJSON FieldFormat where - toJSON = \case - Rfc3339Utc -> String "rfc3339-utc" - Date -> String "date" - Uri -> String "uri" - UriWithScheme scheme -> object ["uriWithScheme" .= scheme] - DocumentHandle prefix -> object ["documentHandle" .= prefix] - -instance ToJSON TypeRule where - toJSON - TypeRule - { type_ = ruleType, - description, - frontmatter, - pathPattern, - resourceScheme, - requireSchemaSection, - schemaColumns, - idPrefix - } = - object - [ "type" .= ruleType, - "description" .= description, - "frontmatter" .= frontmatter, - "pathPattern" .= pathPattern, - "resourceScheme" .= resourceScheme, - "requireSchemaSection" .= requireSchemaSection, - "schemaColumns" .= schemaColumns, - "idPrefix" .= idPrefix - ] - --- | The okf 0.2.x profile record: frontmatter keys were bare strings and --- nothing carried a description. Decoded only as a fallback, so descriptors --- written before descriptions existed keep loading unchanged. Deliberately --- private and deliberately frozen — it is a record of a retired shape, not a --- second profile model. Exercised by --- @okf-core\/test\/fixtures\/profiles\/legacy-0.2.dhall@. -data LegacyProfileSpec = LegacyProfileSpec - { name :: !Text, - okfVersion :: !Text, - frontmatter :: !LegacyFrontmatterRules, - allowUnknownTypes :: !Bool, - idField :: !(Maybe Text), - types :: ![LegacyTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | The okf 0.2.x frontmatter record: two lists of bare key names. -data LegacyFrontmatterRules = LegacyFrontmatterRules - { required :: ![Text], - recommended :: ![Text] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | The okf 0.2.x per-@type@ rule: today's 'TypeRule' without descriptions or --- type-specific frontmatter. -data LegacyTypeRule = LegacyTypeRule - { type_ :: !Text, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall LegacyTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The complete reference-aware descriptor generation, frozen before the --- @optional@ presence list was added to 'FrontmatterRules' and 'NestedRules'. --- This is the immediately preceding public descriptor generation: it matches --- today's shape exactly apart from that third list, so every descriptor written --- as a record literal against the published schema keeps loading. Exercised by --- @okf-core\/test\/fixtures\/profiles\/document-references-ep3.dhall@. -data ReferenceProfileFieldRule = ReferenceProfileFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - elementFields :: !(Maybe ReferenceProfileNestedRules), - reference :: !(Maybe HandleReferenceRule), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ReferenceProfileNestedRules = ReferenceProfileNestedRules - { required :: ![ReferenceProfileNestedFieldRule], - recommended :: ![ReferenceProfileNestedFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ReferenceProfileNestedFieldRule = ReferenceProfileNestedFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ReferenceProfileFrontmatterRules = ReferenceProfileFrontmatterRules - { required :: ![ReferenceProfileFieldRule], - recommended :: ![ReferenceProfileFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ReferenceProfileSpec = ReferenceProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !ReferenceProfileFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![ReferenceProfileTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ReferenceProfileTypeRule = ReferenceProfileTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !ReferenceProfileFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall ReferenceProfileTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The complete condition-aware descriptor generation, frozen before --- top-level document-reference policies were added. -data ConditionalProfileFieldRule = ConditionalProfileFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - elementFields :: !(Maybe ConditionalProfileNestedRules), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ConditionalProfileNestedRules = ConditionalProfileNestedRules - { required :: ![ConditionalProfileNestedFieldRule], - recommended :: ![ConditionalProfileNestedFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ConditionalProfileNestedFieldRule = ConditionalProfileNestedFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - when :: !(Maybe FieldCondition) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ConditionalProfileFrontmatterRules = ConditionalProfileFrontmatterRules - { required :: ![ConditionalProfileFieldRule], - recommended :: ![ConditionalProfileFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ConditionalProfileSpec = ConditionalProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !ConditionalProfileFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![ConditionalProfileTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data ConditionalProfileTypeRule = ConditionalProfileTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !ConditionalProfileFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall ConditionalProfileTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The complete bounded-nested descriptor generation, frozen before --- same-scope field conditions were added. This is the immediately preceding --- public descriptor generation. -data NestedProfileFieldRule = NestedProfileFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - elementFields :: !(Maybe NestedProfileRules) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedProfileRules = NestedProfileRules - { required :: ![NestedProfileNestedFieldRule], - recommended :: ![NestedProfileNestedFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedProfileNestedFieldRule = NestedProfileNestedFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedProfileFrontmatterRules = NestedProfileFrontmatterRules - { required :: ![NestedProfileFieldRule], - recommended :: ![NestedProfileFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedProfileSpec = NestedProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !NestedProfileFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![NestedProfileTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data NestedProfileTypeRule = NestedProfileTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !NestedProfileFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall NestedProfileTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The complete EP-4 field rule, frozen before one-level nested records were --- added. This is the immediately preceding public descriptor generation. -data FormatFieldRule = FormatFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data FormatFrontmatterRules = FormatFrontmatterRules - { required :: ![FormatFieldRule], - recommended :: ![FormatFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data FormatProfileSpec = FormatProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !FormatFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![FormatTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data FormatTypeRule = FormatTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !FormatFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall FormatTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The EP-3 field rule, frozen before named formats were added. -data CardinalityFieldRule = CardinalityFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data CardinalityFrontmatterRules = CardinalityFrontmatterRules - { required :: ![CardinalityFieldRule], - recommended :: ![CardinalityFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | The complete EP-3 profile shape, frozen before named formats were added. -data CardinalityProfileSpec = CardinalityProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !CardinalityFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![CardinalityTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data CardinalityTypeRule = CardinalityTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !CardinalityFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall CardinalityTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The EP-2 field rule, frozen before cardinality was added. -data VocabularyFieldRule = VocabularyFieldRule - { field :: !Text, - description :: !(Maybe Text), - allowedValues :: ![Text] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data VocabularyFrontmatterRules = VocabularyFrontmatterRules - { required :: ![VocabularyFieldRule], - recommended :: ![VocabularyFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | The EP-2 profile shape, frozen before cardinality was added. -data VocabularyProfileSpec = VocabularyProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !VocabularyFrontmatterRules, - allowUnknownTypes :: !Bool, - allowUnknownFields :: !Bool, - idField :: !(Maybe Text), - types :: ![VocabularyTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data VocabularyTypeRule = VocabularyTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !VocabularyFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall VocabularyTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | A field rule from either self-documenting schema generation, before value --- vocabularies were added. -data PreviousFieldRule = PreviousFieldRule - { field :: !Text, - description :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data PreviousFrontmatterRules = PreviousFrontmatterRules - { required :: ![PreviousFieldRule], - recommended :: ![PreviousFieldRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | The type-aware shape from EP-1, frozen before vocabularies and field-name --- closure were added. -data TypeAwareProfileSpec = TypeAwareProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !PreviousFrontmatterRules, - allowUnknownTypes :: !Bool, - idField :: !(Maybe Text), - types :: ![TypeAwareTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data TypeAwareTypeRule = TypeAwareTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - frontmatter :: !PreviousFrontmatterRules, - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall TypeAwareTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - --- | The self-documenting profile shape published immediately before --- type-specific frontmatter rules. It is frozen as a compatibility decoder in --- exactly the same way as the older 0.2.x shape below. -data DescribedProfileSpec = DescribedProfileSpec - { name :: !Text, - description :: !(Maybe Text), - okfVersion :: !Text, - frontmatter :: !PreviousFrontmatterRules, - allowUnknownTypes :: !Bool, - idField :: !(Maybe Text), - types :: ![DescribedTypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - -data DescribedTypeRule = DescribedTypeRule - { type_ :: !Text, - description :: !(Maybe Text), - pathPattern :: !(Maybe Text), - resourceScheme :: !(Maybe Text), - requireSchemaSection :: !Bool, - schemaColumns :: ![Text], - idPrefix :: !(Maybe Text) - } - deriving stock (Generic, Eq, Show) - -instance FromDhall DescribedTypeRule where - autoWith _normalizer = - genericAutoWith - (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) - where - stripTrailingUnderscore fieldName = - fromMaybe fieldName (Text.stripSuffix "_" fieldName) - -emptyFrontmatterRules :: FrontmatterRules -emptyFrontmatterRules = FrontmatterRules {required = [], recommended = [], optional = []} - -upgradeReferenceProfileFrontmatter :: ReferenceProfileFrontmatterRules -> FrontmatterRules -upgradeReferenceProfileFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - elementFields = upgradeNestedRules <$> rule ^. #elementFields, - reference = rule ^. #reference, - when = rule ^. #when - } - upgradeNestedRules rules = - NestedRules - { required = map upgradeNestedField (rules ^. #required), - recommended = map upgradeNestedField (rules ^. #recommended), - optional = [] - } - upgradeNestedField rule = - NestedFieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - when = rule ^. #when - } - -upgradePreviousFrontmatter :: PreviousFrontmatterRules -> FrontmatterRules -upgradePreviousFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = [], - cardinality = Any, - format = Nothing, - elementFields = Nothing, - reference = Nothing, - when = Nothing - } - -upgradeConditionalProfileFrontmatter :: ConditionalProfileFrontmatterRules -> FrontmatterRules -upgradeConditionalProfileFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - elementFields = upgradeNestedRules <$> rule ^. #elementFields, - reference = Nothing, - when = rule ^. #when - } - upgradeNestedRules rules = - NestedRules - { required = map upgradeNestedField (rules ^. #required), - recommended = map upgradeNestedField (rules ^. #recommended), - optional = [] - } - upgradeNestedField rule = - NestedFieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - when = rule ^. #when - } - -upgradeNestedProfileFrontmatter :: NestedProfileFrontmatterRules -> FrontmatterRules -upgradeNestedProfileFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - elementFields = upgradeNestedProfileRules <$> rule ^. #elementFields, - reference = Nothing, - when = Nothing - } - upgradeNestedProfileRules rules = - NestedRules - { required = map upgradeNestedField (rules ^. #required), - recommended = map upgradeNestedField (rules ^. #recommended), - optional = [] - } - upgradeNestedField rule = - NestedFieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - when = Nothing - } - -upgradeFormatFrontmatter :: FormatFrontmatterRules -> FrontmatterRules -upgradeFormatFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = rule ^. #format, - elementFields = Nothing, - reference = Nothing, - when = Nothing - } - -upgradeCardinalityFrontmatter :: CardinalityFrontmatterRules -> FrontmatterRules -upgradeCardinalityFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = rule ^. #cardinality, - format = Nothing, - elementFields = Nothing, - reference = Nothing, - when = Nothing - } - -upgradeVocabularyFrontmatter :: VocabularyFrontmatterRules -> FrontmatterRules -upgradeVocabularyFrontmatter previous = - FrontmatterRules - { required = map upgradeField (previous ^. #required), - recommended = map upgradeField (previous ^. #recommended), - optional = [] - } - where - upgradeField rule = - FieldRule - { field = rule ^. #field, - description = rule ^. #description, - allowedValues = rule ^. #allowedValues, - cardinality = Any, - format = Nothing, - elementFields = Nothing, - reference = Nothing, - when = Nothing - } - -upgradeReferenceProfile :: ReferenceProfileSpec -> ProfileSpec -upgradeReferenceProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeReferenceProfileFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeReferenceProfileFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeConditionalProfile :: ConditionalProfileSpec -> ProfileSpec -upgradeConditionalProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeConditionalProfileFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeConditionalProfileFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeNestedProfile :: NestedProfileSpec -> ProfileSpec -upgradeNestedProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeNestedProfileFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeNestedProfileFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeFormatProfile :: FormatProfileSpec -> ProfileSpec -upgradeFormatProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeFormatFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeFormatFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeCardinalityProfile :: CardinalityProfileSpec -> ProfileSpec -upgradeCardinalityProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeCardinalityFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeCardinalityFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeVocabularyProfile :: VocabularyProfileSpec -> ProfileSpec -upgradeVocabularyProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradeVocabularyFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = previous ^. #allowUnknownFields, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradeVocabularyFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeTypeAwareProfile :: TypeAwareProfileSpec -> ProfileSpec -upgradeTypeAwareProfile previous = - ProfileSpec - { name = previous ^. #name, - description = previous ^. #description, - okfVersion = previous ^. #okfVersion, - frontmatter = upgradePreviousFrontmatter (previous ^. #frontmatter), - allowUnknownTypes = previous ^. #allowUnknownTypes, - allowUnknownFields = True, - idField = previous ^. #idField, - types = map upgradeRule (previous ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = upgradePreviousFrontmatter (rule ^. #frontmatter), - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - -upgradeDescribedProfile :: DescribedProfileSpec -> ProfileSpec -upgradeDescribedProfile described = - ProfileSpec - { name = described ^. #name, - description = described ^. #description, - okfVersion = described ^. #okfVersion, - frontmatter = upgradePreviousFrontmatter (described ^. #frontmatter), - allowUnknownTypes = described ^. #allowUnknownTypes, - allowUnknownFields = True, - idField = described ^. #idField, - types = map upgradeRule (described ^. #types) - } - where - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = rule ^. #description, - frontmatter = emptyFrontmatterRules, - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - --- | Lift a 0.2.x profile into the current shape by attaching no descriptions --- and empty type-specific frontmatter. -upgradeLegacyProfile :: LegacyProfileSpec -> ProfileSpec -upgradeLegacyProfile legacy = - ProfileSpec - { name = legacy ^. #name, - description = Nothing, - okfVersion = legacy ^. #okfVersion, - frontmatter = - FrontmatterRules - { required = map undocumented (legacy ^. #frontmatter . #required), - recommended = map undocumented (legacy ^. #frontmatter . #recommended), - optional = [] - }, - allowUnknownTypes = legacy ^. #allowUnknownTypes, - allowUnknownFields = True, - idField = legacy ^. #idField, - types = map upgradeRule (legacy ^. #types) - } - where - undocumented key = FieldRule {field = key, description = Nothing, allowedValues = [], cardinality = Any, format = Nothing, elementFields = Nothing, reference = Nothing, when = Nothing} - upgradeRule rule = - TypeRule - { type_ = rule ^. #type_, - description = Nothing, - frontmatter = emptyFrontmatterRules, - pathPattern = rule ^. #pathPattern, - resourceScheme = rule ^. #resourceScheme, - requireSchemaSection = rule ^. #requireSchemaSection, - schemaColumns = rule ^. #schemaColumns, - idPrefix = rule ^. #idPrefix - } - --- | Load and decode a Dhall profile descriptor from a file path. Any evaluation --- or decoding failure is captured as a human-readable 'Left'. --- --- The reference-aware shape, condition-aware shape, bounded-nested shape, EP-4 --- format shape, EP-3 cardinality shape, EP-2 vocabulary shape, type-aware EP-1 --- shape, self-documenting shape, and okf 0.2.x shape are accepted by frozen --- fallback decoders and upgraded --- with their no-op defaults. When every decoder fails, the /current/ decoder's --- error is reported. -loadProfileFile :: FilePath -> IO (Either Text ProfileSpec) -loadProfileFile path = do - current <- tryDecode (Dhall.inputFile auto path) - case current of - Right spec -> pure (Right spec) - Left currentError -> do - referenceAware <- tryDecode (Dhall.inputFile auto path) - case referenceAware of - Right referenceSpec -> pure (Right (upgradeReferenceProfile referenceSpec)) - Left _referenceError -> do - conditional <- tryDecode (Dhall.inputFile auto path) - case conditional of - Right conditionalSpec -> pure (Right (upgradeConditionalProfile conditionalSpec)) - Left _conditionalError -> do - nested <- tryDecode (Dhall.inputFile auto path) - case nested of - Right nestedSpec -> pure (Right (upgradeNestedProfile nestedSpec)) - Left _nestedError -> do - formatted <- tryDecode (Dhall.inputFile auto path) - case formatted of - Right formatSpec -> pure (Right (upgradeFormatProfile formatSpec)) - Left _formatError -> do - cardinality <- tryDecode (Dhall.inputFile auto path) - case cardinality of - Right cardinalitySpec -> pure (Right (upgradeCardinalityProfile cardinalitySpec)) - Left _cardinalityError -> do - vocabulary <- tryDecode (Dhall.inputFile auto path) - case vocabulary of - Right vocabularySpec -> pure (Right (upgradeVocabularyProfile vocabularySpec)) - Left _vocabularyError -> do - typeAware <- tryDecode (Dhall.inputFile auto path) - case typeAware of - Right typeAwareSpec -> pure (Right (upgradeTypeAwareProfile typeAwareSpec)) - Left _typeAwareError -> do - described <- tryDecode (Dhall.inputFile auto path) - case described of - Right describedSpec -> pure (Right (upgradeDescribedProfile describedSpec)) - Left _describedError -> do - legacy <- tryDecode (Dhall.inputFile auto path) - pure $ case legacy of - Right legacySpec -> Right (upgradeLegacyProfile legacySpec) - Left _legacyError -> Left currentError - where - -- The ten calls look identical but are inferred at distinct result types; - -- @auto@ picks the corresponding current or frozen decoder. - tryDecode :: IO a -> IO (Either Text a) - tryDecode action = - (Right <$> action) - `catch` \(exception :: SomeException) -> pure (Left (Text.pack (show exception))) - --- | Does an already-evaluated Dhall expression decode as a profile? Tries the --- current schema, then the reference-aware, condition-aware, bounded-nested, --- EP-4, EP-3, EP-2, EP-1, self-documenting, and okf 0.2.x schemas, --- so the published @okf-profiles@ package still enumerates. Uses --- 'Dhall.rawInput', which normalizes and runs the decoder's extractor without --- throwing, which is what lets registry enumeration be pure. -decodeProfileExpr :: Expr Src Void -> Maybe ProfileSpec -decodeProfileExpr expression = - Dhall.rawInput Dhall.auto expression - <|> fmap upgradeReferenceProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeConditionalProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeNestedProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeFormatProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeCardinalityProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeVocabularyProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeTypeAwareProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeDescribedProfile (Dhall.rawInput Dhall.auto expression) - <|> fmap upgradeLegacyProfile (Dhall.rawInput Dhall.auto expression) - --- | The description a profile attaches to a frontmatter key, looking in --- @required@ first, then @recommended@, then @optional@. 'Nothing' when the key --- is undocumented or absent from the profile entirely. -profileFieldDescription :: ProfileSpec -> Text -> Maybe Text -profileFieldDescription spec key = - case [rule | rule <- rules, rule ^. #field == key] of - (rule : _) -> rule ^. #description - [] -> Nothing - where - rules = - spec ^. #frontmatter . #required - <> spec ^. #frontmatter . #recommended - <> spec ^. #frontmatter . #optional - --- | A malformed profile definition. The optional type is absent for profile --- scope and present for a type-specific scope. The list name is @required@, --- @recommended@, or @optional@. -data ProfileDefinitionError - = DuplicateTypeRule Text - | DuplicateFieldRule (Maybe Text) Text Text - | ConflictingFieldRequirement (Maybe Text) Text - | UnsatisfiableVocabulary (Maybe Text) Text [Text] [Text] - | ConflictingCardinality (Maybe Text) Text Cardinality Cardinality - | ElementFieldsRequireList (Maybe Text) FieldPath Cardinality - | InvalidFormatParameter FieldPath FieldFormat Text - | ConflictingFieldFormat FieldPath FieldFormat FieldFormat - | EmptyConditionValues (Maybe Text) FieldPath FieldPath - | ConditionFieldNotDeclared (Maybe Text) FieldPath FieldPath - | ConditionFieldNotScalar (Maybe Text) FieldPath FieldPath Cardinality - | ConditionFieldOpenVocabulary (Maybe Text) FieldPath FieldPath - | ConditionFieldHasUnreachableValues (Maybe Text) FieldPath FieldPath [Text] [Text] - | SelfConditionalField (Maybe Text) FieldPath - | InvalidReferencePrefix (Maybe Text) FieldPath Text - | ReferencePrefixNotDeclared (Maybe Text) FieldPath Text - | ReferenceRequiresIdField (Maybe Text) FieldPath - | InvalidExternalReferenceScheme (Maybe Text) FieldPath Text - | ConflictingReferencePrefix Text FieldPath Text Text - | ReferenceWithFormat (Maybe Text) FieldPath FieldFormat - | -- | an @optional@ rule carries a @when@ condition, which gates only presence - -- and is therefore dead: an optional rule has no presence check at all - OptionalFieldWithCondition (Maybe Text) FieldPath - deriving stock (Generic, Eq, Ord, Show) - -data FieldRequirement = RecommendedField | RequiredField - deriving stock (Eq, Ord, Show) - -data CompiledCondition = CompiledCondition - { field :: !Text, - hasValue :: ![Text] - } - deriving stock (Generic, Eq, Show) - -data PresenceClause = PresenceClause - { requirement :: !FieldRequirement, - condition :: !(Maybe CompiledCondition) - } - deriving stock (Generic, Eq, Show) - -data EffectiveFieldRule = EffectiveFieldRule - { presenceClauses :: ![PresenceClause], - description :: !(Maybe Text), - allowedValues :: ![Text], - cardinality :: !Cardinality, - format :: !(Maybe FieldFormat), - elementFields :: !(Maybe (Map Text EffectiveFieldRule)), - reference :: !(Maybe HandleReferenceRule) - } - deriving stock (Generic, Eq, Show) - --- | A raw profile whose authoring contradictions have been rejected and whose --- effective profile-plus-type frontmatter rules have been precomputed. -data CompiledProfile = CompiledProfile - { spec :: !ProfileSpec, - baseRules :: !(Map Text EffectiveFieldRule), - rulesByType :: !(Map Text (Map Text EffectiveFieldRule)) - } - deriving stock (Generic, Eq, Show) - -compiledProfileSpec :: CompiledProfile -> ProfileSpec -compiledProfileSpec compiled = compiled ^. #spec - -compileProfile :: ProfileSpec -> Either (NonEmpty ProfileDefinitionError) CompiledProfile -compileProfile rawSpec = - case definitionErrors of - firstError : remainingErrors -> Left (firstError :| remainingErrors) - [] -> - Right - CompiledProfile - { spec = rawSpec, - baseRules, - rulesByType = - Map.fromList - [ (rule ^. #type_, mergeRules baseRules (compileRules (rule ^. #frontmatter))) - | rule <- rawSpec ^. #types - ] - } - where - baseRules = compileRules (rawSpec ^. #frontmatter) - typeNames = map (^. #type_) (rawSpec ^. #types) - definitionErrors = - List.sortOn definitionErrorKey $ - map DuplicateTypeRule (duplicates typeNames) - <> scopeErrors Nothing (rawSpec ^. #frontmatter) - <> concat - [ scopeErrors (Just (rule ^. #type_)) (rule ^. #frontmatter) - | rule <- rawSpec ^. #types - ] - <> vocabularyErrors - <> cardinalityErrors - <> nestedCardinalityErrors - <> formatParameterErrors - <> conflictingFormatErrors - <> conditionDefinitionErrors - <> referenceDefinitionErrors - - definitionErrorKey = \case - DuplicateTypeRule ctype -> (1 :: Int, ctype, 0 :: Int, "", 0 :: Int) - DuplicateFieldRule scope listName key -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, listKey listName, key, 0) - ConflictingFieldRequirement scope key -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 2, key, 0) - UnsatisfiableVocabulary scope key _ _ -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 3, key, 0) - ConflictingCardinality scope key _ _ -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 4, key, 0) - ElementFieldsRequireList scope path cardinality -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 4, renderFieldPathKey path, fromEnum (cardinality == Scalar)) - InvalidFormatParameter path fieldFormat parameter -> - (2, renderFieldPathKey path, 5, Text.pack (show fieldFormat), Text.length parameter) - ConflictingFieldFormat path profileFormat typeFormat -> - (2, renderFieldPathKey path, 6, Text.pack (show profileFormat), fromEnum (profileFormat == typeFormat)) - EmptyConditionValues scope target source -> conditionErrorKey scope target source 7 - ConditionFieldNotDeclared scope target source -> conditionErrorKey scope target source 8 - ConditionFieldNotScalar scope target source cardinality -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 9, renderFieldPathKey target <> ":" <> renderFieldPathKey source, fromEnum (cardinality == Scalar)) - ConditionFieldOpenVocabulary scope target source -> conditionErrorKey scope target source 10 - ConditionFieldHasUnreachableValues scope target source _ _ -> conditionErrorKey scope target source 11 - SelfConditionalField scope target -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 12, renderFieldPathKey target, 0) - InvalidReferencePrefix scope target prefix -> referenceErrorKey scope target 13 prefix - ReferencePrefixNotDeclared scope target prefix -> referenceErrorKey scope target 14 prefix - ReferenceRequiresIdField scope target -> referenceErrorKey scope target 15 "" - InvalidExternalReferenceScheme scope target scheme -> referenceErrorKey scope target 16 scheme - ConflictingReferencePrefix ctype target profilePrefix typePrefix -> - (1, ctype, 17, renderFieldPathKey target <> ":" <> profilePrefix, Text.length typePrefix) - ReferenceWithFormat scope target fieldFormat -> referenceErrorKey scope target 18 (Text.pack (show fieldFormat)) - OptionalFieldWithCondition scope target -> - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, 19, renderFieldPathKey target, 0) - - scopeKey Nothing = (0, "") - scopeKey (Just ctype) = (1, ctype) - listKey "required" = 0 - listKey _ = 1 - conditionErrorKey scope target source rank = - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, rank, renderFieldPathKey target <> ":" <> renderFieldPathKey source, 0) - referenceErrorKey scope target rank detail = - let (scopeRank, typeName) = scopeKey scope - in (scopeRank, typeName, rank, renderFieldPathKey target <> ":" <> detail, 0) - - scopeErrors scope FrontmatterRules {required, recommended, optional} = - [DuplicateFieldRule scope "required" key | key <- duplicates (map (^. #field) required)] - <> [DuplicateFieldRule scope "recommended" key | key <- duplicates (map (^. #field) recommended)] - <> [DuplicateFieldRule scope "optional" key | key <- duplicates (map (^. #field) optional)] - <> [ ConflictingFieldRequirement scope key - | key <- presenceListCollisions (map (^. #field) required) (map (^. #field) recommended) (map (^. #field) optional) - ] - <> concatMap (nestedScopeErrors scope) (required <> recommended <> optional) - - nestedScopeErrors scope parentRule = - case parentRule ^. #elementFields of - Nothing -> [] - Just NestedRules {required, recommended, optional} -> - let qualify key = parentRule ^. #field <> "." <> key - in [DuplicateFieldRule scope "nested required" (qualify key) | key <- duplicates (map (^. #field) required)] - <> [DuplicateFieldRule scope "nested recommended" (qualify key) | key <- duplicates (map (^. #field) recommended)] - <> [DuplicateFieldRule scope "nested optional" (qualify key) | key <- duplicates (map (^. #field) optional)] - <> [ ConflictingFieldRequirement scope (qualify key) - | key <- presenceListCollisions (map (^. #field) required) (map (^. #field) recommended) (map (^. #field) optional) - ] - - -- One key classified by more than one presence list at a single scope. The - -- profile cannot say both "always check for this" and "never check for - -- this", so any pairing is a definition error rather than a precedence rule. - presenceListCollisions requiredKeys recommendedKeys optionalKeys = - List.nub . List.sort . concat $ - [ List.intersect requiredKeys recommendedKeys, - List.intersect requiredKeys optionalKeys, - List.intersect recommendedKeys optionalKeys - ] - - duplicates = mapMaybe duplicateHead . List.group . List.sort - duplicateHead (candidate : _ : _) = Just candidate - duplicateHead _ = Nothing - - vocabularyErrors = - [ UnsatisfiableVocabulary (Just (rule ^. #type_)) key profileValues typeValues - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - let profileValues = profileRule ^. #allowedValues - typeValues = typeRule ^. #allowedValues, - not (null profileValues), - not (null typeValues), - null (mergeVocabulary profileValues typeValues) - ] - <> [ UnsatisfiableVocabulary (Just (rule ^. #type_)) (parentKey <> "." <> nestedKey) profileValues typeValues - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - Just profileNested <- [profileRule ^. #elementFields], - Just typeNested <- [typeRule ^. #elementFields], - (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), - let profileValues = profileNestedRule ^. #allowedValues - typeValues = typeNestedRule ^. #allowedValues, - not (null profileValues), - not (null typeValues), - null (mergeVocabulary profileValues typeValues) - ] - - cardinalityErrors = - [ ConflictingCardinality (Just (rule ^. #type_)) key profileCardinality typeCardinality - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - let profileCardinality = profileRule ^. #cardinality - typeCardinality = typeRule ^. #cardinality, - profileCardinality /= Any, - typeCardinality /= Any, - profileCardinality /= typeCardinality - ] - <> [ ConflictingCardinality (Just (rule ^. #type_)) (parentKey <> "." <> nestedKey) profileCardinality typeCardinality - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - Just profileNested <- [profileRule ^. #elementFields], - Just typeNested <- [typeRule ^. #elementFields], - (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), - let profileCardinality = profileNestedRule ^. #cardinality - typeCardinality = typeNestedRule ^. #cardinality, - profileCardinality /= Any, - typeCardinality /= Any, - profileCardinality /= typeCardinality - ] - - nestedCardinalityErrors = - [ ElementFieldsRequireList scope (topLevelFieldPath (fieldRule ^. #field)) Scalar - | (scope, rules) <- (Nothing, rawSpec ^. #frontmatter) : [(Just (rule ^. #type_), rule ^. #frontmatter) | rule <- rawSpec ^. #types], - fieldRule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, - isJust (fieldRule ^. #elementFields), - fieldRule ^. #cardinality == Scalar - ] - - formatParameterErrors = - [ InvalidFormatParameter (topLevelFieldPath (rule ^. #field)) fieldFormat parameter - | rules <- (rawSpec ^. #frontmatter) : map (^. #frontmatter) (rawSpec ^. #types), - rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, - Just (fieldFormat, parameter) <- [invalidFormatParameter =<< rule ^. #format] - ] - <> [ InvalidFormatParameter (nestedDefinitionPath (rule ^. #field) (nestedRule ^. #field)) fieldFormat parameter - | rules <- (rawSpec ^. #frontmatter) : map (^. #frontmatter) (rawSpec ^. #types), - rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, - Just nestedRules <- [rule ^. #elementFields], - nestedRule <- nestedRules ^. #required <> nestedRules ^. #recommended <> nestedRules ^. #optional, - Just (fieldFormat, parameter) <- [invalidFormatParameter =<< nestedRule ^. #format] - ] - - conflictingFormatErrors = - [ ConflictingFieldFormat (topLevelFieldPath key) profileFormat typeFormat - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - Just profileFormat <- [profileRule ^. #format], - Just typeFormat <- [typeRule ^. #format], - mergeFieldFormat (Just profileFormat) (Just typeFormat) == Nothing - ] - <> [ ConflictingFieldFormat (nestedDefinitionPath parentKey nestedKey) profileFormat typeFormat - | rule <- rawSpec ^. #types, - let typeRules = compileRules (rule ^. #frontmatter), - (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), - Just profileNested <- [profileRule ^. #elementFields], - Just typeNested <- [typeRule ^. #elementFields], - (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), - Just profileFormat <- [profileNestedRule ^. #format], - Just typeFormat <- [typeNestedRule ^. #format], - mergeFieldFormat (Just profileFormat) (Just typeFormat) == Nothing - ] - - conditionDefinitionErrors = - conditionErrors Nothing Nothing (rawSpec ^. #frontmatter) baseRules - <> concat - [ let typeRules = compileRules (rule ^. #frontmatter) - mergedRules = mergeRules baseRules typeRules - in conditionErrors (Just (rule ^. #type_)) Nothing (rule ^. #frontmatter) mergedRules - | rule <- rawSpec ^. #types - ] - - conditionErrors scope parent rules effectiveRules = - concatMap (fieldConditionErrors scope parent effectiveRules) (rules ^. #required <> rules ^. #recommended) - <> [ deadCondition scope parent (rawRule ^. #field) - | rawRule <- rules ^. #optional, - isJust (rawRule ^. #when) - ] - <> concat - [ case (rawRule ^. #elementFields, Map.lookup (rawRule ^. #field) effectiveRules >>= (^. #elementFields)) of - (Just nestedRules, Just effectiveNestedRules) -> - concatMap - (fieldConditionErrors scope (Just (rawRule ^. #field)) effectiveNestedRules) - (nestedRules ^. #required <> nestedRules ^. #recommended) - <> [ deadCondition scope (Just (rawRule ^. #field)) (nestedRule ^. #field) - | nestedRule <- nestedRules ^. #optional, - isJust (nestedRule ^. #when) - ] - _ -> [] - | rawRule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional - ] - - -- A condition gates presence, and an optional rule has no presence clause to - -- gate, so the pairing is dead in the descriptor rather than a weaker rule. - deadCondition scope parent key = - OptionalFieldWithCondition - scope - (maybe (topLevelFieldPath key) (\parentKey -> nestedDefinitionPath parentKey key) parent) - - fieldConditionErrors scope parent effectiveRules rawRule = - case rawRule ^. #when of - Nothing -> [] - Just FieldCondition {field = sourceKey, hasValue = conditionValues} -> - let targetKey = rawRule ^. #field - targetPath = maybe (topLevelFieldPath targetKey) (\parentKey -> nestedDefinitionPath parentKey targetKey) parent - sourcePath = maybe (topLevelFieldPath sourceKey) (\parentKey -> nestedDefinitionPath parentKey sourceKey) parent - normalizedValues = deduplicate conditionValues - sourceErrors = - case Map.lookup sourceKey effectiveRules of - Nothing -> [ConditionFieldNotDeclared scope targetPath sourcePath] - Just sourceRule -> - [ ConditionFieldNotScalar scope targetPath sourcePath (sourceRule ^. #cardinality) - | sourceRule ^. #cardinality /= Scalar - ] - <> [ ConditionFieldOpenVocabulary scope targetPath sourcePath - | null (sourceRule ^. #allowedValues) - ] - <> let unreachable = filter (`notElem` sourceRule ^. #allowedValues) normalizedValues - in [ ConditionFieldHasUnreachableValues scope targetPath sourcePath unreachable (sourceRule ^. #allowedValues) - | not (null (sourceRule ^. #allowedValues)), - not (null unreachable) - ] - in [EmptyConditionValues scope targetPath sourcePath | null normalizedValues] - <> [SelfConditionalField scope targetPath | targetKey == sourceKey] - <> sourceErrors - - referenceDefinitionErrors = - List.nub $ - concatMap rawReferenceErrors scopedRules - <> concatMap mergedReferenceErrors (rawSpec ^. #types) - where - declaredPrefixes = mapMaybe (^. #idPrefix) (rawSpec ^. #types) - scopedRules = - (Nothing, rawSpec ^. #frontmatter) - : [(Just (rule ^. #type_), rule ^. #frontmatter) | rule <- rawSpec ^. #types] - - rawReferenceErrors (scope, rules) = - concatMap (fieldReferenceErrors scope) (rules ^. #required <> rules ^. #recommended <> rules ^. #optional) - - fieldReferenceErrors scope rule = - case rule ^. #reference of - Nothing -> [] - Just policy -> - let path = topLevelFieldPath (rule ^. #field) - prefix = policy ^. #localPrefix - schemes = deduplicateSchemes (policy ^. #externalUriSchemes) - in [InvalidReferencePrefix scope path prefix | not (validDocumentHandlePrefix prefix)] - <> [ReferencePrefixNotDeclared scope path prefix | prefix `notElem` declaredPrefixes] - <> [ReferenceRequiresIdField scope path | isNothing (rawSpec ^. #idField)] - <> [InvalidExternalReferenceScheme scope path scheme | scheme <- schemes, not (validUriScheme scheme)] - <> [ReferenceWithFormat scope path fieldFormat | Just fieldFormat <- [rule ^. #format]] - - mergedReferenceErrors typeRule = - [ ConflictingReferencePrefix (typeRule ^. #type_) (topLevelFieldPath key) (profilePolicy ^. #localPrefix) (typePolicy ^. #localPrefix) - | let typeFields = compileRules (typeRule ^. #frontmatter), - (key, (profileRule, typeFieldRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeFields), - Just profilePolicy <- [profileRule ^. #reference], - Just typePolicy <- [typeFieldRule ^. #reference], - profilePolicy ^. #localPrefix /= typePolicy ^. #localPrefix - ] - <> [ ReferenceWithFormat (Just (typeRule ^. #type_)) (topLevelFieldPath key) fieldFormat - | let typeFields = compileRules (typeRule ^. #frontmatter), - (key, (profileRule, typeFieldRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeFields), - (referenceRule, formatRule) <- [(profileRule, typeFieldRule), (typeFieldRule, profileRule)], - isJust (referenceRule ^. #reference), - Just fieldFormat <- [formatRule ^. #format] - ] - - renderFieldPathKey (FieldPath (firstSegment :| remainingSegments)) = - Text.intercalate "." (map renderSegment (firstSegment : remainingSegments)) - renderSegment (FieldName name) = name - renderSegment (ArrayIndex elementIndex) = Text.pack (show elementIndex) - -compileRules :: FrontmatterRules -> Map Text EffectiveFieldRule -compileRules FrontmatterRules {required, recommended, optional} = - Map.fromList - ( [ (rule ^. #field, compileFieldRule RequiredField rule) - | rule <- required - ] - <> [ (rule ^. #field, compileFieldRule RecommendedField rule) - | rule <- recommended - ] - <> [ (rule ^. #field, compileOptionalFieldRule rule) - | rule <- optional - ] - ) - --- | Compile a rule the profile documents but never demands. It carries no --- presence clause, so 'applicablePresenceClause' can never find one to report in --- either validation mode, while every value check still runs from the --- present-value branch. This is also the value constraints a required or --- recommended rule is built from. -compileOptionalFieldRule :: FieldRule -> EffectiveFieldRule -compileOptionalFieldRule rule = - EffectiveFieldRule - { presenceClauses = [], - description = rule ^. #description, - allowedValues = deduplicate (rule ^. #allowedValues), - cardinality = - case (rule ^. #elementFields, rule ^. #cardinality) of - (Just _, Any) -> List - (_, cardinality) -> cardinality, - format = rule ^. #format, - elementFields = compileNestedRules <$> rule ^. #elementFields, - reference = compileReferenceRule <$> rule ^. #reference - } - -compileFieldRule :: FieldRequirement -> FieldRule -> EffectiveFieldRule -compileFieldRule requirement rule = - (compileOptionalFieldRule rule) - { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)] - } - -compileNestedRules :: NestedRules -> Map Text EffectiveFieldRule -compileNestedRules NestedRules {required, recommended, optional} = - Map.fromList - ( [ (rule ^. #field, compileNestedFieldRule RequiredField rule) - | rule <- required - ] - <> [ (rule ^. #field, compileNestedFieldRule RecommendedField rule) - | rule <- recommended - ] - <> [ (rule ^. #field, compileOptionalNestedFieldRule rule) - | rule <- optional - ] - ) - --- | The nested counterpart of 'compileOptionalFieldRule'. -compileOptionalNestedFieldRule :: NestedFieldRule -> EffectiveFieldRule -compileOptionalNestedFieldRule rule = - EffectiveFieldRule - { presenceClauses = [], - description = rule ^. #description, - allowedValues = deduplicate (rule ^. #allowedValues), - cardinality = rule ^. #cardinality, - format = rule ^. #format, - elementFields = Nothing, - reference = Nothing - } - -compileNestedFieldRule :: FieldRequirement -> NestedFieldRule -> EffectiveFieldRule -compileNestedFieldRule requirement rule = - (compileOptionalNestedFieldRule rule) - { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)] - } - -mergeRules :: Map Text EffectiveFieldRule -> Map Text EffectiveFieldRule -> Map Text EffectiveFieldRule -mergeRules = Map.unionWith mergeEffectiveFieldRule - -mergeEffectiveFieldRule :: EffectiveFieldRule -> EffectiveFieldRule -> EffectiveFieldRule -mergeEffectiveFieldRule profileRule typeRule = - EffectiveFieldRule - { presenceClauses = profileRule ^. #presenceClauses <> typeRule ^. #presenceClauses, - description = typeRule ^. #description <|> profileRule ^. #description, - allowedValues = mergeVocabulary (profileRule ^. #allowedValues) (typeRule ^. #allowedValues), - cardinality = mergeCardinality (profileRule ^. #cardinality) (typeRule ^. #cardinality), - format = fromMaybe (profileRule ^. #format) (mergeFieldFormat (profileRule ^. #format) (typeRule ^. #format)), - elementFields = mergeElementFields (profileRule ^. #elementFields) (typeRule ^. #elementFields), - reference = fromMaybe (profileRule ^. #reference) (mergeReferenceRule (profileRule ^. #reference) (typeRule ^. #reference)) - } - -compileCondition :: FieldCondition -> CompiledCondition -compileCondition rawCondition = - CompiledCondition - { field = rawCondition ^. #field, - hasValue = deduplicate (rawCondition ^. #hasValue) - } - -compileReferenceRule :: HandleReferenceRule -> HandleReferenceRule -compileReferenceRule policy = - HandleReferenceRule - { localPrefix = policy ^. #localPrefix, - externalUriSchemes = map Text.toCaseFold (deduplicateSchemes (policy ^. #externalUriSchemes)), - allowSelf = policy ^. #allowSelf - } - -mergeElementFields :: Maybe (Map Text EffectiveFieldRule) -> Maybe (Map Text EffectiveFieldRule) -> Maybe (Map Text EffectiveFieldRule) -mergeElementFields Nothing typeRules = typeRules -mergeElementFields profileRules Nothing = profileRules -mergeElementFields (Just profileRules) (Just typeRules) = Just (Map.unionWith mergeEffectiveFieldRule profileRules typeRules) - -mergeReferenceRule :: Maybe HandleReferenceRule -> Maybe HandleReferenceRule -> Maybe (Maybe HandleReferenceRule) -mergeReferenceRule Nothing typePolicy = Just typePolicy -mergeReferenceRule profilePolicy Nothing = Just profilePolicy -mergeReferenceRule (Just profilePolicy) (Just typePolicy) - | profilePolicy ^. #localPrefix == typePolicy ^. #localPrefix = - Just . Just $ - HandleReferenceRule - { localPrefix = profilePolicy ^. #localPrefix, - externalUriSchemes = - filter - (`Set.member` Set.fromList (typePolicy ^. #externalUriSchemes)) - (profilePolicy ^. #externalUriSchemes), - allowSelf = profilePolicy ^. #allowSelf && typePolicy ^. #allowSelf - } - | otherwise = Nothing - -mergeFieldFormat :: Maybe FieldFormat -> Maybe FieldFormat -> Maybe (Maybe FieldFormat) -mergeFieldFormat Nothing typeFormat = Just typeFormat -mergeFieldFormat profileFormat Nothing = Just profileFormat -mergeFieldFormat (Just Uri) (Just typeFormat@(UriWithScheme _)) = Just (Just typeFormat) -mergeFieldFormat (Just profileFormat@(UriWithScheme _)) (Just Uri) = Just (Just profileFormat) -mergeFieldFormat profileFormat typeFormat - | profileFormat == typeFormat = Just profileFormat - | otherwise = Nothing - -invalidFormatParameter :: FieldFormat -> Maybe (FieldFormat, Text) -invalidFormatParameter fieldFormat = - case fieldFormat of - UriWithScheme scheme - | not (validUriScheme scheme) -> Just (fieldFormat, scheme) - DocumentHandle prefix - | not (validDocumentHandlePrefix prefix) -> Just (fieldFormat, prefix) - _ -> Nothing - -validUriScheme :: Text -> Bool -validUriScheme scheme = - case Text.uncons scheme of - Just (firstCharacter, rest) -> isAsciiLetter firstCharacter && Text.all validRest rest - Nothing -> False - where - validRest character = - isAsciiLetter character - || ('0' <= character && character <= '9') - || character `elem` ['+', '.', '-'] - -validDocumentHandlePrefix :: Text -> Bool -validDocumentHandlePrefix prefix = - case parseDocumentId (prefix <> "-1") of - Just documentId -> documentId ^. #prefix == prefix - Nothing -> False - -isAsciiLetter :: Char -> Bool -isAsciiLetter character = isAsciiLower character || isAsciiUpper character - -mergeCardinality :: Cardinality -> Cardinality -> Cardinality -mergeCardinality Any typeCardinality = typeCardinality -mergeCardinality profileCardinality Any = profileCardinality -mergeCardinality profileCardinality _typeCardinality = profileCardinality - -mergeVocabulary :: [Text] -> [Text] -> [Text] -mergeVocabulary [] typeValues = typeValues -mergeVocabulary profileValues [] = profileValues -mergeVocabulary profileValues typeValues = - filter (`Set.member` Set.fromList typeValues) profileValues - -deduplicate :: [Text] -> [Text] -deduplicate = go Set.empty - where - go _ [] = [] - go seen (value : rest) - | value `Set.member` seen = go seen rest - | otherwise = value : go (Set.insert value seen) rest - -deduplicateSchemes :: [Text] -> [Text] -deduplicateSchemes = go Set.empty - where - go _ [] = [] - go seen (scheme : rest) - | normalized `Set.member` seen = go seen rest - | otherwise = scheme : go (Set.insert normalized seen) rest - where - normalized = Text.toCaseFold scheme - -effectiveRulesForType :: CompiledProfile -> Text -> Map Text EffectiveFieldRule -effectiveRulesForType compiled ctype = - Map.findWithDefault (compiled ^. #baseRules) ctype (compiled ^. #rulesByType) - -profileFieldDescriptionForType :: CompiledProfile -> Text -> Text -> Maybe Text -profileFieldDescriptionForType compiled ctype key = - Map.lookup key (effectiveRulesForType compiled ctype) >>= (^. #description) - --- | A parsed document handle: an ASCII-letter-led alphanumeric prefix and a --- positive number, rendered as @PREFIX-N@. -data DocumentId = DocumentId - { prefix :: !Text, - number :: !Natural - } - deriving stock (Generic, Eq, Ord, Show) - --- | Parse a strict document handle. The prefix contains one or more ASCII --- letters or digits and begins with a letter. It is followed by exactly one --- hyphen and a positive decimal number with no leading zero. Thus @ADR-7@ --- parses, while @ADR-007@, @ADR-0@, @ADR-@, @-7@, @adr 7@, and --- @ADR-7-extra@ do not. -parseDocumentId :: Text -> Maybe DocumentId -parseDocumentId raw = - case Text.splitOn "-" raw of - [prefixText, numberText] - | validPrefix prefixText, - validNumberText numberText -> - case Text.Read.decimal numberText of - Right (parsedNumber, remainder) - | Text.null remainder, - parsedNumber > 0 -> - Just (DocumentId prefixText parsedNumber) - _ -> Nothing - _ -> Nothing - where - validPrefix value = - case Text.uncons value of - Just (firstCharacter, rest) -> - isAsciiLetter firstCharacter && Text.all isAsciiAlphaNumeric rest - Nothing -> False - validNumberText value = - case Text.uncons value of - Just (firstCharacter, rest) -> - firstCharacter >= '1' - && firstCharacter <= '9' - && Text.all isAsciiDigit rest - Nothing -> False - isAsciiDigit character = - character >= '0' && character <= '9' - isAsciiAlphaNumeric character = - isAsciiLetter character || isAsciiDigit character - --- | Render a document handle as @PREFIX-N@. -renderDocumentId :: DocumentId -> Text -renderDocumentId DocumentId {prefix, number} = - prefix <> "-" <> Text.pack (show number) - --- | Every well-formed handle under the profile's ID field, paired with the --- concept carrying it and sorted by prefix, number, then concept ID. Concepts --- without a well-formed handle are omitted. A profile with no ID field yields --- an empty list. -documentIdsInBundle :: ProfileSpec -> [Concept] -> [(DocumentId, ConceptId)] -documentIdsInBundle spec concepts = - case spec ^. #idField of - Nothing -> [] - Just fieldName -> - List.sortOn - (\(documentId, cid) -> (documentId, renderConceptId cid)) - [ (documentId, conceptIdOf concept) - | concept <- concepts, - Just (String rawDocumentId) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], - Just documentId <- [parseDocumentId rawDocumentId] - ] - --- | Allocate one more than the highest document-ID number already used for the --- given prefix, or number 1 when the prefix is unused. Gaps are deliberately --- not filled: reusing a retired number could make an old reference silently --- point at a different document. -nextDocumentId :: ProfileSpec -> [Concept] -> Text -> DocumentId -nextDocumentId spec concepts requestedPrefix = - DocumentId - { prefix = requestedPrefix, - number = highestNumber + 1 - } - where - highestNumber = - List.foldl' - max - 0 - [ documentId ^. #number - | (documentId, _) <- documentIdsInBundle spec concepts, - documentId ^. #prefix == requestedPrefix - ] - --- | One structural segment of a frontmatter path. EP-2 produces top-level --- 'FieldName' paths; later bounded nested validation can append field names and --- array indexes without encoding paths as ad hoc text. -data FieldPathSegment - = FieldName Text - | ArrayIndex Int - deriving stock (Generic, Eq, Ord, Show) - -newtype FieldPath = FieldPath - { segments :: NonEmpty FieldPathSegment - } - deriving stock (Generic, Eq, Ord, Show) - -topLevelFieldPath :: Text -> FieldPath -topLevelFieldPath key = FieldPath (FieldName key :| []) - -nestedDefinitionPath :: Text -> Text -> FieldPath -nestedDefinitionPath parent child = - FieldPath (FieldName parent :| [FieldName child]) - -nestedValuePath :: Text -> Int -> Text -> FieldPath -nestedValuePath parent elementIndex child = - FieldPath (FieldName parent :| [ArrayIndex elementIndex, FieldName child]) - -nestedElementPath :: Text -> Int -> FieldPath -nestedElementPath parent elementIndex = - FieldPath (FieldName parent :| [ArrayIndex elementIndex]) - --- | A single deviation from a profile. Advisory by default at the CLI layer. -data ProfileViolation - = -- | concept's @type@ is not listed in the profile and unknown types are disallowed - TypeNotInProfile ConceptId Text - | -- | a required frontmatter key is missing or empty (concept, key, activating condition) - MissingProfileField ConceptId Text (Maybe FieldCondition) - | -- | a recommended frontmatter key is missing under strict authoring - MissingRecommendedProfileField ConceptId Text (Maybe FieldCondition) - | -- | a required field is missing inside one list element record - MissingNestedProfileField ConceptId FieldPath (Maybe FieldCondition) - | -- | a recommended nested field is missing under strict authoring - MissingRecommendedNestedProfileField ConceptId FieldPath (Maybe FieldCondition) - | -- | a present value is outside the effective textual vocabulary - ValueNotInVocabulary ConceptId FieldPath [Text] Value - | -- | a present value has the wrong scalar/list shape - CardinalityMismatch ConceptId FieldPath Cardinality Value - | -- | a present value does not satisfy its named textual format - ValueFormatMismatch ConceptId FieldPath FieldFormat Value - | -- | a local reference has the right prefix but no valid owner in this bundle - DanglingHandleReference ConceptId FieldPath Text - | -- | a parsed local handle uses a prefix other than the declared target prefix - ReferenceHandlePrefixMismatch ConceptId FieldPath Text Text - | -- | a reference value is neither textual local handle nor valid absolute URI - MalformedDocumentReference ConceptId FieldPath Value - | -- | an absolute external URI uses a scheme the profile did not permit - ExternalReferenceSchemeNotAllowed ConceptId FieldPath Text [Text] - | -- | a local handle resolves to the concept carrying the reference - SelfDocumentReference ConceptId FieldPath Text - | -- | a closed profile does not declare this top-level field - FieldNotInProfile ConceptId Text - | -- | a declared list element is not an object record - NestedElementNotRecord ConceptId FieldPath Value - | -- | concept's file path does not match the type rule's pattern (concept, type, pattern) - PathPatternMismatch ConceptId Text Text - | -- | type rule requires a resource scheme but resource is absent (concept, type, scheme) - MissingResource ConceptId Text Text - | -- | resource present but its scheme is wrong (concept, expected scheme, actual resource) - ResourceSchemeMismatch ConceptId Text Text - | -- | required @# Schema@ section is absent (concept, type) - MissingSchemaSection ConceptId Text - | -- | @# Schema@ table columns do not match (concept, type, expected, actual) - SchemaColumnsMismatch ConceptId Text [Text] [Text] - | -- | type rule declares an @idPrefix@ but the concept has no handle (concept, type, prefix) - MissingDocumentId ConceptId Text Text - | -- | handle present but malformed for the declared prefix (concept, prefix, actual value) - MalformedDocumentId ConceptId Text Text - | -- | the same handle appears on more than one concept (handle, concept, other concept) - DuplicateDocumentId Text ConceptId ConceptId - deriving stock (Generic, Eq, Show) - --- | Check every concept against a compiled profile, returning all deviations. --- Profile-wide rules apply even to unknown types; a matching type rule adds its --- frontmatter rules and the existing type-specific structural checks. -validateProfile :: ValidationProfile -> CompiledProfile -> [Concept] -> [ProfileViolation] -validateProfile validationProfile compiled concepts = - concatMap checkConcept sortedConcepts <> checkDuplicateDocumentIds spec sortedConcepts - where - spec = compiledProfileSpec compiled - sortedConcepts = List.sortOn (renderConceptId . conceptIdOf) concepts - rulesByType = [(rule ^. #type_, rule) | rule <- spec ^. #types] - validDocumentIdIndex = buildValidDocumentIdIndex spec rulesByType sortedConcepts - - checkConcept concept = - let cid = conceptIdOf concept - ctype = conceptType concept - fieldViolations = checkFields cid ctype concept <> checkUnknownFields cid ctype concept - in case lookup ctype rulesByType of - Nothing -> - [TypeNotInProfile cid ctype | not (spec ^. #allowUnknownTypes)] <> fieldViolations - Just rule -> - fieldViolations - <> checkPath cid ctype rule - <> checkResource cid ctype rule concept - <> checkSchema cid ctype rule concept - <> checkDocumentId spec cid ctype rule concept - - checkFields cid ctype concept = - concatMap checkField (Map.toAscList (effectiveRulesForType compiled ctype)) - where - checkField (key, rule) = - case evaluateFieldValue (rule ^. #cardinality) (frontmatterLookup key (conceptFrontmatter concept)) of - FieldAbsent actual -> - presenceViolations key rule - <> maybe [] (vocabularyViolations key rule) actual - <> maybe [] (formatViolations key rule) actual - <> maybe [] (referenceViolations key rule) actual - FieldPresent actual -> - vocabularyViolations key rule actual - <> formatViolations key rule actual - <> referenceViolations key rule actual - <> nestedViolations key rule actual - FieldWrongShape actual -> [CardinalityMismatch cid (topLevelFieldPath key) (rule ^. #cardinality) actual] - - presenceViolations key rule = - case applicablePresenceClause validationProfile (\sourceKey -> frontmatterLookup sourceKey (conceptFrontmatter concept)) rule of - Nothing -> [] - Just clause -> - [ case clause ^. #requirement of - RequiredField -> MissingProfileField cid key (conditionForViolation <$> clause ^. #condition) - RecommendedField -> MissingRecommendedProfileField cid key (conditionForViolation <$> clause ^. #condition) - ] - vocabularyViolations key rule actual = - [ ValueNotInVocabulary cid (topLevelFieldPath key) (rule ^. #allowedValues) actual - | not (null (rule ^. #allowedValues)), - not (valueMatchesVocabulary (rule ^. #allowedValues) actual) - ] - formatViolations key rule actual = - [ ValueFormatMismatch cid (topLevelFieldPath key) fieldFormat actual - | Just fieldFormat <- [rule ^. #format], - not (valueMatchesFormat fieldFormat actual) - ] - referenceViolations key rule actual = - case rule ^. #reference of - Nothing -> [] - Just policy -> validateReferenceValue validDocumentIdIndex cid (topLevelFieldPath key) policy actual - - nestedViolations parentKey parentRule = \case - Array elementValues - | Just nestedRules <- parentRule ^. #elementFields -> - concat - [ case elementValue of - Object objectFields -> - concatMap - (checkNestedField parentKey elementIndex objectFields) - (Map.toAscList nestedRules) - _ -> [NestedElementNotRecord cid (nestedElementPath parentKey elementIndex) elementValue] - | (elementIndex, elementValue) <- zip [0 ..] (Vector.toList elementValues) - ] - _ -> [] - - checkNestedField parentKey elementIndex objectFields (key, rule) = - let path = nestedValuePath parentKey elementIndex key - actualValue = Aeson.KeyMap.lookup (Aeson.Key.fromText key) objectFields - in case evaluateFieldValue (rule ^. #cardinality) actualValue of - FieldAbsent actual -> - nestedPresenceViolations objectFields path rule - <> maybe [] (nestedVocabularyViolations path rule) actual - <> maybe [] (nestedFormatViolations path rule) actual - FieldPresent actual -> - nestedVocabularyViolations path rule actual - <> nestedFormatViolations path rule actual - FieldWrongShape actual -> [CardinalityMismatch cid path (rule ^. #cardinality) actual] - - nestedPresenceViolations objectFields path rule = - case applicablePresenceClause validationProfile lookupSibling rule of - Nothing -> [] - Just clause -> - [ case clause ^. #requirement of - RequiredField -> MissingNestedProfileField cid path (conditionForViolation <$> clause ^. #condition) - RecommendedField -> MissingRecommendedNestedProfileField cid path (conditionForViolation <$> clause ^. #condition) - ] - where - lookupSibling sourceKey = Aeson.KeyMap.lookup (Aeson.Key.fromText sourceKey) objectFields - nestedVocabularyViolations path rule actual = - [ ValueNotInVocabulary cid path (rule ^. #allowedValues) actual - | not (null (rule ^. #allowedValues)), - not (valueMatchesVocabulary (rule ^. #allowedValues) actual) - ] - nestedFormatViolations path rule actual = - [ ValueFormatMismatch cid path fieldFormat actual - | Just fieldFormat <- [rule ^. #format], - not (valueMatchesFormat fieldFormat actual) - ] - - checkUnknownFields cid ctype concept - | spec ^. #allowUnknownFields = [] - | otherwise = - [ FieldNotInProfile cid key - | key <- frontmatterKeys (conceptFrontmatter concept), - key `Set.notMember` allowedFields ctype - ] - - allowedFields ctype = - coreFrontmatterFields - <> Map.keysSet (effectiveRulesForType compiled ctype) - <> maybe Set.empty Set.singleton (spec ^. #idField) - --- | Index only handles that are valid owners under the compiled profile's raw --- type declarations: the concept has a matching type rule, that rule declares --- the parsed handle's exact prefix, and the profile declares the owning field. --- Multiple owners are retained so a duplicate target still counts as existing; --- the existing bundle-wide duplicate diagnostic remains authoritative. -buildValidDocumentIdIndex :: ProfileSpec -> [(Text, TypeRule)] -> [Concept] -> Map DocumentId [ConceptId] -buildValidDocumentIdIndex spec rulesByType concepts = - case spec ^. #idField of - Nothing -> Map.empty - Just fieldName -> - Map.fromListWith - (flip (<>)) - [ (documentId, [conceptIdOf concept]) - | concept <- concepts, - Just typeRule <- [lookup (conceptType concept) rulesByType], - Just expectedPrefix <- [typeRule ^. #idPrefix], - Just (String rawDocumentId) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], - Just documentId <- [parseDocumentId rawDocumentId], - documentId ^. #prefix == expectedPrefix - ] - -validateReferenceValue :: Map DocumentId [ConceptId] -> ConceptId -> FieldPath -> HandleReferenceRule -> Value -> [ProfileViolation] -validateReferenceValue validOwners sourceConcept path policy = \case - String rawReference -> validateReferenceText validOwners sourceConcept path policy rawReference - Array values -> - concat - [ case value of - String rawReference -> validateReferenceText validOwners sourceConcept (appendArrayIndex path elementIndex) policy rawReference - _ -> [MalformedDocumentReference sourceConcept (appendArrayIndex path elementIndex) value] - | (elementIndex, value) <- zip [0 ..] (Vector.toList values) - ] - actual -> [MalformedDocumentReference sourceConcept path actual] - -validateReferenceText :: Map DocumentId [ConceptId] -> ConceptId -> FieldPath -> HandleReferenceRule -> Text -> [ProfileViolation] -validateReferenceText validOwners sourceConcept path policy rawReference = - case parseDocumentId rawReference of - Just documentId - | documentId ^. #prefix /= policy ^. #localPrefix -> - [ReferenceHandlePrefixMismatch sourceConcept path rawReference (policy ^. #localPrefix)] - | otherwise -> - case Map.lookup documentId validOwners of - Nothing -> [DanglingHandleReference sourceConcept path rawReference] - Just owners - | not (policy ^. #allowSelf), - sourceConcept `elem` owners -> - [SelfDocumentReference sourceConcept path rawReference] - | otherwise -> [] - Nothing -> - case parseURI (Text.unpack rawReference) of - Just parsed - | not (Text.null normalizedScheme), normalizedScheme `elem` policy ^. #externalUriSchemes -> [] - | not (Text.null normalizedScheme) -> - [ ExternalReferenceSchemeNotAllowed - sourceConcept - path - normalizedScheme - (policy ^. #externalUriSchemes) - ] - | otherwise -> [MalformedDocumentReference sourceConcept path (String rawReference)] - where - normalizedScheme = Text.toCaseFold (Text.dropWhileEnd (== ':') (Text.pack (uriScheme parsed))) - Nothing -> [MalformedDocumentReference sourceConcept path (String rawReference)] - -appendArrayIndex :: FieldPath -> Int -> FieldPath -appendArrayIndex (FieldPath pathSegments) elementIndex = - FieldPath (pathSegments <> (ArrayIndex elementIndex :| [])) - -applicablePresenceClause :: ValidationProfile -> (Text -> Maybe Value) -> EffectiveFieldRule -> Maybe PresenceClause -applicablePresenceClause validationProfile lookupValue rule = - List.find applies requiredClauses - <|> if validationProfile == StrictAuthoring then List.find applies recommendedClauses else Nothing - where - requiredClauses = filter ((== RequiredField) . (^. #requirement)) (rule ^. #presenceClauses) - recommendedClauses = filter ((== RecommendedField) . (^. #requirement)) (rule ^. #presenceClauses) - applies clause = maybe True conditionApplies (clause ^. #condition) - conditionApplies condition = - case lookupValue (condition ^. #field) of - Just (String actual) -> actual `elem` condition ^. #hasValue - _ -> False - -conditionForViolation :: CompiledCondition -> FieldCondition -conditionForViolation condition = - FieldCondition - { field = condition ^. #field, - hasValue = condition ^. #hasValue - } - -valueMatchesVocabulary :: [Text] -> Value -> Bool -valueMatchesVocabulary allowed = \case - String value -> value `elem` allowed - Array values -> all elementMatches (Vector.toList values) - _ -> False - where - elementMatches (String value) = value `elem` allowed - elementMatches _ = False - -valueMatchesFormat :: FieldFormat -> Value -> Bool -valueMatchesFormat fieldFormat = \case - String value -> textMatchesFormat fieldFormat value - Array values -> all elementMatches (Vector.toList values) - _ -> False - where - elementMatches (String value) = textMatchesFormat fieldFormat value - elementMatches _ = False - -textMatchesFormat :: FieldFormat -> Text -> Bool -textMatchesFormat fieldFormat value = - case fieldFormat of - Rfc3339Utc -> - hasExtendedUtcShape value - && isJust (iso8601ParseM (Text.unpack value) :: Maybe UTCTime) - Date -> - hasExtendedDateShape value - && isJust (iso8601ParseM (Text.unpack value) :: Maybe Day) - Uri -> isJust (parseURI (Text.unpack value)) - UriWithScheme expectedScheme -> - case parseURI (Text.unpack value) of - Just parsed -> - Text.toCaseFold (Text.dropWhileEnd (== ':') (Text.pack (uriScheme parsed))) - == Text.toCaseFold expectedScheme - Nothing -> False - DocumentHandle expectedPrefix -> - case parseDocumentId value of - Just documentId -> documentId ^. #prefix == expectedPrefix - Nothing -> False - -hasExtendedDateShape :: Text -> Bool -hasExtendedDateShape value = - Text.length value == 10 - && Text.index value 4 == '-' - && Text.index value 7 == '-' - -hasExtendedUtcShape :: Text -> Bool -hasExtendedUtcShape value = - Text.length value >= 20 - && Text.index value 4 == '-' - && Text.index value 7 == '-' - && Text.index value 10 == 'T' - && Text.index value 13 == ':' - && Text.index value 16 == ':' - && Text.last value == 'Z' - -data FieldValueEvaluation - = FieldAbsent (Maybe Value) - | FieldPresent Value - | FieldWrongShape Value - -evaluateFieldValue :: Cardinality -> Maybe Value -> FieldValueEvaluation -evaluateFieldValue _ Nothing = FieldAbsent Nothing -evaluateFieldValue Any (Just actual) - | legacyValueIsPresent actual = FieldPresent actual - | otherwise = FieldAbsent (Just actual) -evaluateFieldValue Scalar (Just actual) = - case actual of - String value - | Text.null (Text.strip value) -> FieldAbsent (Just actual) - | otherwise -> FieldPresent actual - Number _ -> FieldPresent actual - Bool _ -> FieldPresent actual - _ -> FieldWrongShape actual -evaluateFieldValue List (Just actual) = - case actual of - Array values - | null values -> FieldAbsent (Just actual) - | otherwise -> FieldPresent actual - _ -> FieldWrongShape actual - -legacyValueIsPresent :: Value -> Bool -legacyValueIsPresent = \case - String value -> not (Text.null (Text.strip value)) - Array values -> not (null values) - _ -> False - --- | Check a profile-declared document ID for one concept. -checkDocumentId :: ProfileSpec -> ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] -checkDocumentId spec cid ctype rule concept = - case (spec ^. #idField, rule ^. #idPrefix) of - (Just fieldName, Just expectedPrefix) -> - case frontmatterLookup fieldName (conceptFrontmatter concept) of - Just (String value) - | not (Text.null (Text.strip value)) -> - case parseDocumentId value of - Just documentId - | documentId ^. #prefix == expectedPrefix -> [] - _ -> [MalformedDocumentId cid expectedPrefix value] - _ -> [MissingDocumentId cid ctype expectedPrefix] - _ -> [] - --- | Check every non-empty value under the profile's ID field for bundle-wide --- uniqueness. Concept IDs are sorted before grouping so output is deterministic. -checkDuplicateDocumentIds :: ProfileSpec -> [Concept] -> [ProfileViolation] -checkDuplicateDocumentIds spec concepts = - case spec ^. #idField of - Nothing -> [] - Just fieldName -> - concatMap duplicateViolations (groupedHandles fieldName) - where - groupedHandles fieldName = - List.groupBy - (\(leftHandle, _) (rightHandle, _) -> leftHandle == rightHandle) - (handles fieldName) - handles fieldName = - List.sortOn - (\(handle, cid) -> (handle, renderConceptId cid)) - [ (handle, conceptIdOf concept) - | concept <- concepts, - Just (String handle) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], - not (Text.null (Text.strip handle)) - ] - duplicateViolations ((handle, firstConcept) : duplicates) = - [ DuplicateDocumentId handle firstConcept duplicateConcept - | (_, duplicateConcept) <- duplicates - ] - duplicateViolations [] = [] - --- | Project a concept's frontmatter (the document's @frontmatter@ field). -conceptFrontmatter :: Concept -> Frontmatter -conceptFrontmatter concept = conceptDocument concept ^. #frontmatter - --- | A type rule's @pathPattern@, when present, constrains where the concept's --- file may live. -checkPath :: ConceptId -> Text -> TypeRule -> [ProfileViolation] -checkPath cid ctype rule = - case rule ^. #pathPattern of - Nothing -> [] - Just patternText - | matchPathPattern patternText cid -> [] - | otherwise -> [PathPatternMismatch cid ctype patternText] - --- | Match a concept ID against a segment-glob pattern. @*@ matches exactly one --- segment; a single trailing @**@ matches one or more remaining segments; every --- other segment matches literally. Both segment lists must be consumed exactly, --- except for the trailing @**@ case. -matchPathPattern :: Text -> ConceptId -> Bool -matchPathPattern patternText cid = - go (Text.splitOn "/" patternText) (Text.splitOn "/" (renderConceptId cid)) - where - go [] [] = True - go ["**"] (_ : _) = True - go ("*" : ps) (_ : ss) = go ps ss - go (p : ps) (s : ss) = p == s && go ps ss - go _ _ = False - --- | A type rule's @resourceScheme@, when present, requires a @resource:@ value --- whose scheme matches. -checkResource :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] -checkResource cid ctype rule concept = - case rule ^. #resourceScheme of - Nothing -> [] - Just scheme -> - case conceptResource concept of - Nothing -> [MissingResource cid ctype scheme] - Just value - | (scheme <> "://") `Text.isPrefixOf` value -> [] - | otherwise -> [ResourceSchemeMismatch cid scheme value] - --- | A type rule's @# Schema@ contract: when @requireSchemaSection@ is set, the --- body must contain a @# Schema@ section whose table header begins with the --- required @schemaColumns@ (case-insensitive, trimmed, compared as a prefix so a --- team may add trailing columns without tripping the check). -checkSchema :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] -checkSchema cid ctype rule concept - | not (rule ^. #requireSchemaSection) = [] - | otherwise = - case schemaSectionColumns (conceptDocument concept ^. #body) of - Nothing -> [MissingSchemaSection cid ctype] - Just actual -> - let expected = rule ^. #schemaColumns - norm = map (Text.toLower . Text.strip) - in [ SchemaColumnsMismatch cid ctype expected actual - | not (norm expected `List.isPrefixOf` norm actual) - ] - --- | The header-row columns of the first GitHub-flavored table that follows the --- first top-level @# Schema@ heading, or 'Nothing' if there is no Schema heading --- or no following table. Columns are trimmed. -schemaSectionColumns :: Text -> Maybe [Text] -schemaSectionColumns markdown = - let CMarkGFM.Node _ _ topLevel = CMarkGFM.commonmarkToNode [] [CMarkGFM.extTable] markdown + PathReferenceRule (..), + FieldRule (..), + NestedRules (..), + NestedFieldRule (..), + Cardinality (..), + FieldFormat (..), + TypeRule (..), + FieldPath (..), + FieldPathSegment (..), + loadProfileFile, + decodeProfileExpr, + profileFieldDescription, + CompiledProfile, + ProfileDefinitionError (..), + compileProfile, + compiledProfileSpec, + compiledProfileRequiredBundleVersion, + profileFieldDescriptionForType, + + -- * Compiled rule inspection + + -- | A read-only window onto what a compiled profile actually demands. The + -- rule types are abstract on purpose: read them through the accessors below + -- so that later profile features can extend the compiled encoding without + -- breaking consumers. + -- + -- Two encodings are easy to misread and are worth stating up front. An + -- __empty presence-clause list means the key is optional__, not that it is + -- unconstrained; and an __empty allowed-value list means unconstrained__, + -- not that no value is permitted. + EffectiveFieldRule, + PresenceClause, + FieldRequirement (..), + fieldRulePresenceClauses, + presenceClauseRequirement, + presenceClauseCondition, + fieldRuleDescription, + fieldRuleAllowedValues, + fieldRuleCardinality, + fieldRuleFormat, + fieldRuleReference, + fieldRulePath, + fieldRuleElementFields, + fieldRuleObjectFields, + compiledProfileTypeNames, + compiledProfileBaseRules, + compiledProfileRulesForType, + renderCardinalityName, + renderFieldFormatName, + + -- * Validation + DocumentId (..), + parseDocumentId, + renderDocumentId, + documentIdsInBundle, + nextDocumentId, + ProfileViolation (..), + validateProfile, + validateProfileWith, + validateProfileVersion, + + -- * Body inspection + schemaSectionColumns, + ) +where + +import CMarkGFM qualified +import Control.Exception (SomeException, catch) +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Aeson.Key +import Data.Aeson.KeyMap qualified as Aeson.KeyMap +import Data.Char (isAsciiLower, isAsciiUpper) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Read qualified as Text.Read +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Vector qualified as Vector +import Data.Void (Void) +import Dhall (FromDhall (..), auto, genericAutoWith) +import Dhall qualified +import Dhall.Core (Expr) +import Dhall.Src (Src) +import Network.URI (parseURI, uriScheme) +import Numeric.Natural (Natural) +-- Imported qualified: 'Okf.Actor.HumanActor' is a constructor of 'Actor.Actor' +-- and 'HumanActor' is a constructor of 'FieldFormat', so an unqualified import +-- makes the two ambiguous. +import Okf.Actor qualified as Actor +import Okf.Bundle + ( BundleInventory, + Concept, + bundleInventoryMember, + bundleInventoryOfConcepts, + conceptDocument, + conceptIdOf, + conceptResource, + conceptType, + ) +import Okf.ConceptId (ConceptId, conceptIdFromFilePath, renderConceptId) +import Okf.Document + ( Frontmatter, + coreFrontmatterFields, + fieldsSupersededInV02, + frontmatterKeys, + frontmatterLookup, + ) +import Okf.Index + ( OkfVersion (..), + VersionDeclaration (..), + parseOkfVersion, + renderOkfVersion, + supportedOkfVersion, + ) +import Okf.Markdown (markdownOptions) +import Okf.Path (PathReference (..), classifyPathReference) +-- 'List' and 'Object' are 'Cardinality' constructors here; the names aeson uses +-- for the corresponding 'Value' constructors are reached as 'Aeson.Array' and +-- 'Aeson.Object'. +import Okf.Prelude hiding (List, Object, (.=)) +import Okf.Validation (ValidationProfile (..)) +import System.FilePath qualified as FilePath +import "generic-lens" Data.Generics.Labels () + +-- | A complete house profile. @description@ is prose documenting the profile as +-- a whole; like every description in this module it is never checked against a +-- bundle and can never produce a 'ProfileViolation'. +-- +-- @requireBundleVersion@ and @okfVersion@ are easy to confuse and answer +-- different questions. @okfVersion@ says which version's rules /this profile +-- writes/, and 'compileProfile' checks the profile's own rules against it. +-- @requireBundleVersion@ says what the profile demands of a /bundle/: @Just +-- \"0.2\"@ means the bundle's root @index.md@ must declare @okf_version@ at 0.2 +-- or later, checked by 'validateProfileVersion'. Neither constrains the other. +data ProfileSpec = ProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !FrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + requireBundleVersion :: !(Maybe Text), + types :: ![TypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Frontmatter keys the profile expects on every concept. @required@ is always +-- checked, @recommended@ only under 'StrictAuthoring', and @optional@ never: +-- an optional key is fully validated whenever it is present and its absence is +-- never a deviation in any mode. +data FrontmatterRules = FrontmatterRules + { required :: ![FieldRule], + recommended :: ![FieldRule], + optional :: ![FieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A same-scope predicate controlling whether a field's presence rule applies. +-- The source field must compile to a closed scalar textual vocabulary. +data FieldCondition = FieldCondition + { field :: !Text, + hasValue :: ![Text] + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | A top-level field whose textual values point either to a local document +-- handle with one prefix or to an absolute URI with an explicitly allowed +-- scheme. External targets are never resolved by okf. +data HandleReferenceRule = HandleReferenceRule + { localPrefix :: !Text, + externalUriSchemes :: ![Text], + allowSelf :: !Bool + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | A field whose values name a path or URI per OKF v0.2 specification §6.2: an +-- absolute URL, a bundle-relative path beginning with @\/@, or an ordinary +-- relative path resolved against the concept's own directory. +-- +-- Deliberately distinct from 'HandleReferenceRule'. A handle resolves against +-- the bundle's document-ID index and fails by carrying the wrong prefix or +-- having no owner; a path resolves against the concept tree and fails by not +-- being a §6.2 shape, by climbing above the bundle root, or by naming a concept +-- that is not there. Declaring both on one rule is a definition error. +-- +-- An empty @externalUriSchemes@ means no absolute URL is permitted at all, so a +-- separate "must be a path, never a URL" flag would say nothing new. Which +-- bundle paths okf can resolve depends on the entry point: 'validateProfileWith' +-- resolves every file the bundle holds, including §6.3's +-- @references\/attesters\/revenue.py@, while 'validateProfile' is handed +-- concepts alone and so resolves @.md@ targets only. +data PathReferenceRule = PathReferenceRule + { externalUriSchemes :: ![Text], + allowSelf :: !Bool + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | One documented frontmatter key. The description is prose for humans and is +-- never checked against a bundle. +-- +-- @elementFields@ and @objectFields@ describe two different shapes. +-- @elementFields@ constrains the record inside /each element of a list/; +-- @objectFields@ constrains the record that /is/ the value. Declaring both means +-- either spelling is accepted and both are checked against the same member +-- rules, which is how a profile describes the OKF v0.2 @verified@ key. +data FieldRule = FieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + elementFields :: !(Maybe NestedRules), + objectFields :: !(Maybe NestedRules), + reference :: !(Maybe HandleReferenceRule), + path :: !(Maybe PathReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Rules for the flat object stored in each element of a list-valued field, or +-- in the mapping that is the value of an object-valued field. The nested rule +-- type has neither an @elementFields@ nor an @objectFields@ member, which makes +-- the public descriptor depth-bounded rather than recursive. +data NestedRules = NestedRules + { required :: ![NestedFieldRule], + recommended :: ![NestedFieldRule], + optional :: ![NestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | One field inside a list element record or an object-valued mapping. It +-- carries @path@ because @sources[].resource@ is the motivating path-valued +-- field of §6.2 and lives inside a list element; it deliberately carries no +-- @reference@, because no v0.2 field names a document handle at nested scope. +data NestedFieldRule = NestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + path :: !(Maybe PathReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Whether a key must be a single value, a non-empty list, a mapping, or any +-- of them. 'Object' is placed last so the derived 'Ord' keeps the relative +-- order of the three published alternatives, which the definition-error sort key +-- relies on. +data Cardinality = Any | Scalar | List | Object + deriving stock (Generic, Eq, Ord, Show) + +-- | Decoded from the three-alternative published union in +-- @okf-core\/dhall\/Cardinality.dhall@. 'Object' is deliberately unreachable +-- from Dhall: it is produced only by compilation, when a rule declares +-- @objectFields@. Adding an alternative to the published union would change the +-- type of every value written against it and would break descriptors pinned to +-- the previous schema, which no record-level fallback decoder can repair, +-- because every frozen generation in the chain refers to this same type. An +-- author who wants to say "this key must be a mapping" and nothing more writes +-- @objectFields = Some NestedRules::{=}@. +instance FromDhall Cardinality where + autoWith _normalizer = + Dhall.union + ( (Any <$ Dhall.constructor "Any" Dhall.unit) + <> (Scalar <$ Dhall.constructor "Scalar" Dhall.unit) + <> (List <$ Dhall.constructor "List" Dhall.unit) + ) + +-- | A named value format. Formats constrain present values but do not imply +-- that a field must be present. +-- +-- The first five constrain text. 'Actor' and 'HumanActor' constrain text against +-- the OKF v0.2 actor convention of specification §7, classified by +-- 'Okf.Actor.parseActor'. 'Integer', 'NonNegativeInteger', and 'Boolean' +-- constrain a value that is not text at all; declaring one of them refines an +-- unspecified cardinality to 'Scalar', because otherwise a numeric or boolean +-- key is reported missing before its value is ever examined. +-- +-- The OKF v0.2 alternatives are appended after 'DocumentHandle' so the derived +-- 'Ord' keeps the relative order of the original five, which the +-- definition-error sort key relies on. +data FieldFormat + = Rfc3339Utc + | Date + | Uri + | UriWithScheme Text + | DocumentHandle Text + | Actor + | HumanActor + | Integer + | NonNegativeInteger + | Boolean + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | One rule per allowed concept @type@ string. +data TypeRule = TypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !FrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | Decode @type_@ from the Dhall field @type@ by stripping the trailing +-- underscore; all other fields map by their exact name. (Mirrors how +-- 'Okf.Bundle' uses a @type_@ field to avoid clashing with the @type@ keyword.) +instance FromDhall TypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | Encode a profile so tooling can consume the same descriptor okf reads. +-- Written by hand rather than derived so the key order is stable and, more +-- importantly, so 'TypeRule' emits @type@ rather than the Haskell field name +-- @type_@ — matching the Dhall field and how 'Okf.Graph.Node' already encodes. +instance ToJSON ProfileSpec where + toJSON ProfileSpec {name, description, okfVersion, frontmatter, allowUnknownTypes, allowUnknownFields, idField, requireBundleVersion, types = typeRules} = + object + [ "name" .= name, + "description" .= description, + "okfVersion" .= okfVersion, + "requireBundleVersion" .= requireBundleVersion, + "allowUnknownTypes" .= allowUnknownTypes, + "allowUnknownFields" .= allowUnknownFields, + "idField" .= idField, + "frontmatter" .= frontmatter, + "types" .= typeRules + ] + +instance ToJSON FrontmatterRules where + toJSON FrontmatterRules {required, recommended, optional} = + object + [ "required" .= required, + "recommended" .= recommended, + "optional" .= optional + ] + +instance ToJSON FieldCondition where + toJSON FieldCondition {field = fieldName, hasValue} = + object + [ "field" .= fieldName, + "hasValue" .= hasValue + ] + +instance ToJSON HandleReferenceRule where + toJSON HandleReferenceRule {localPrefix, externalUriSchemes, allowSelf} = + object + [ "localPrefix" .= localPrefix, + "externalUriSchemes" .= externalUriSchemes, + "allowSelf" .= allowSelf + ] + +instance ToJSON PathReferenceRule where + toJSON PathReferenceRule {externalUriSchemes, allowSelf} = + object + [ "externalUriSchemes" .= externalUriSchemes, + "allowSelf" .= allowSelf + ] + +instance ToJSON FieldRule where + toJSON FieldRule {field = fieldName, description, allowedValues, cardinality, format, elementFields, objectFields, reference, path = pathRule, when = condition} = + object + [ "field" .= fieldName, + "description" .= description, + "allowedValues" .= allowedValues, + "cardinality" .= cardinality, + "format" .= format, + "elementFields" .= elementFields, + "reference" .= reference, + "when" .= condition, + -- Appended rather than placed beside @elementFields@, so that the list + -- reads as "the keys this instance has always emitted, then the ones + -- added since". A consumer keys on names, not position. + "objectFields" .= objectFields, + "path" .= pathRule + ] + +instance ToJSON NestedRules where + toJSON NestedRules {required, recommended, optional} = + object + [ "required" .= required, + "recommended" .= recommended, + "optional" .= optional + ] + +instance ToJSON NestedFieldRule where + toJSON NestedFieldRule {field = fieldName, description, allowedValues, cardinality, format, path = pathRule, when = condition} = + object + [ "field" .= fieldName, + "description" .= description, + "allowedValues" .= allowedValues, + "cardinality" .= cardinality, + "format" .= format, + "when" .= condition, + -- Appended for the same reason 'FieldRule' appends @objectFields@. + "path" .= pathRule + ] + +instance ToJSON Cardinality where + toJSON = String . cardinalityName + +cardinalityName :: Cardinality -> Text +cardinalityName = \case + Any -> "any" + Scalar -> "scalar" + List -> "list" + Object -> "object" + +instance ToJSON FieldFormat where + toJSON = \case + Rfc3339Utc -> String "rfc3339-utc" + Date -> String "date" + Uri -> String "uri" + UriWithScheme scheme -> object ["uriWithScheme" .= scheme] + DocumentHandle prefix -> object ["documentHandle" .= prefix] + Actor -> String "actor" + HumanActor -> String "human-actor" + Integer -> String "integer" + NonNegativeInteger -> String "non-negative-integer" + Boolean -> String "boolean" + +instance ToJSON TypeRule where + toJSON + TypeRule + { type_ = ruleType, + description, + frontmatter, + pathPattern, + resourceScheme, + requireSchemaSection, + schemaColumns, + idPrefix + } = + object + [ "type" .= ruleType, + "description" .= description, + "frontmatter" .= frontmatter, + "pathPattern" .= pathPattern, + "resourceScheme" .= resourceScheme, + "requireSchemaSection" .= requireSchemaSection, + "schemaColumns" .= schemaColumns, + "idPrefix" .= idPrefix + ] + +-- | The okf 0.2.x profile record: frontmatter keys were bare strings and +-- nothing carried a description. Decoded only as a fallback, so descriptors +-- written before descriptions existed keep loading unchanged. Deliberately +-- private and deliberately frozen — it is a record of a retired shape, not a +-- second profile model. Exercised by +-- @okf-core\/test\/fixtures\/profiles\/legacy-0.2.dhall@. +data LegacyProfileSpec = LegacyProfileSpec + { name :: !Text, + okfVersion :: !Text, + frontmatter :: !LegacyFrontmatterRules, + allowUnknownTypes :: !Bool, + idField :: !(Maybe Text), + types :: ![LegacyTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The okf 0.2.x frontmatter record: two lists of bare key names. +data LegacyFrontmatterRules = LegacyFrontmatterRules + { required :: ![Text], + recommended :: ![Text] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The okf 0.2.x per-@type@ rule: today's 'TypeRule' without descriptions or +-- type-specific frontmatter. +data LegacyTypeRule = LegacyTypeRule + { type_ :: !Text, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall LegacyTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The five-alternative published format union, frozen before the OKF v0.2 +-- value formats were added. +-- +-- Unlike every other frozen shape below this is a /union/ rather than a record. +-- A Dhall union value carries its full alternative set in its type, so a +-- descriptor pinned to the five-alternative +-- @okf-core\/dhall\/FieldFormat.dhall@ does not typecheck against the current +-- decoder, and no record-level fallback can repair that: every frozen generation +-- would still refer to the widened 'FieldFormat'. Every frozen generation below +-- therefore refers to this type instead. +-- +-- The instance is hand-written rather than derived so that the Dhall alternative +-- names stay @Rfc3339Utc@ and friends while the Haskell constructors stay +-- distinct from the current type's. +data PreV02FieldFormat + = LegacyRfc3339Utc + | LegacyDate + | LegacyUri + | LegacyUriWithScheme Text + | LegacyDocumentHandle Text + deriving stock (Generic, Eq, Ord, Show) + +instance FromDhall PreV02FieldFormat where + autoWith _normalizer = + Dhall.union + ( (LegacyRfc3339Utc <$ Dhall.constructor "Rfc3339Utc" Dhall.unit) + <> (LegacyDate <$ Dhall.constructor "Date" Dhall.unit) + <> (LegacyUri <$ Dhall.constructor "Uri" Dhall.unit) + <> (LegacyUriWithScheme <$> Dhall.constructor "UriWithScheme" Dhall.auto) + <> (LegacyDocumentHandle <$> Dhall.constructor "DocumentHandle" Dhall.auto) + ) + +upgradePreV02FieldFormat :: PreV02FieldFormat -> FieldFormat +upgradePreV02FieldFormat = \case + LegacyRfc3339Utc -> Rfc3339Utc + LegacyDate -> Date + LegacyUri -> Uri + LegacyUriWithScheme scheme -> UriWithScheme scheme + LegacyDocumentHandle prefix -> DocumentHandle prefix + +-- | The complete descriptor generation frozen before a profile could require its +-- bundle to declare an OKF version. This is the immediately preceding public +-- descriptor generation: it is today's shape minus the @requireBundleVersion@ +-- member on the top-level record. That member is the only difference, so every +-- rule record, every type rule, and every union is unchanged and is shared +-- rather than copied — the freezing rule of +-- @docs\/adr\/11-growing-the-profile-descriptor-language.md@ is about the +-- descriptor as a whole, and a generation that changes one record copies only +-- what changed. Exercised by +-- @okf-core\/test\/fixtures\/profiles\/pre-bundle-version.dhall@. +data PreBundleVersionProfileSpec = PreBundleVersionProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !FrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![TypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The complete descriptor generation frozen before path-valued reference +-- rules were added: today's shape minus the @path@ member on 'FieldRule' and on +-- 'NestedFieldRule'. Because that is a record addition rather than a union +-- widening, 'Cardinality', 'FieldFormat', 'FieldCondition', and +-- 'HandleReferenceRule' are unchanged by it and so are shared rather than +-- copied; the two rule records and everything that contains them are copied. +-- Exercised by @okf-core\/test\/fixtures\/profiles\/path-references-mp8-ep3.dhall@. +data PrePathProfileFieldRule = PrePathProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + elementFields :: !(Maybe PrePathProfileNestedRules), + objectFields :: !(Maybe PrePathProfileNestedRules), + reference :: !(Maybe HandleReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PrePathProfileNestedRules = PrePathProfileNestedRules + { required :: ![PrePathProfileNestedFieldRule], + recommended :: ![PrePathProfileNestedFieldRule], + optional :: ![PrePathProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PrePathProfileNestedFieldRule = PrePathProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PrePathProfileFrontmatterRules = PrePathProfileFrontmatterRules + { required :: ![PrePathProfileFieldRule], + recommended :: ![PrePathProfileFieldRule], + optional :: ![PrePathProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PrePathProfileSpec = PrePathProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !PrePathProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![PrePathProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PrePathProfileTypeRule = PrePathProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !PrePathProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall PrePathProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete object-rule descriptor generation, frozen before the OKF v0.2 +-- value formats were added to 'FieldFormat'. Its records match the shape +-- 'PrePathProfileFieldRule' froze — no @path@ member — and the further +-- difference is that every @format@ member refers to the frozen +-- five-alternative 'PreV02FieldFormat'. Exercised by +-- @okf-core\/test\/fixtures\/profiles\/formats-mp8-ep2.dhall@. +data PreActorProfileFieldRule = PreActorProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + elementFields :: !(Maybe PreActorProfileNestedRules), + objectFields :: !(Maybe PreActorProfileNestedRules), + reference :: !(Maybe HandleReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreActorProfileNestedRules = PreActorProfileNestedRules + { required :: ![PreActorProfileNestedFieldRule], + recommended :: ![PreActorProfileNestedFieldRule], + optional :: ![PreActorProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreActorProfileNestedFieldRule = PreActorProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreActorProfileFrontmatterRules = PreActorProfileFrontmatterRules + { required :: ![PreActorProfileFieldRule], + recommended :: ![PreActorProfileFieldRule], + optional :: ![PreActorProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreActorProfileSpec = PreActorProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !PreActorProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![PreActorProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreActorProfileTypeRule = PreActorProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !PreActorProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall PreActorProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete optional-presence descriptor generation, frozen before object +-- rules were added: it matches the shape before @objectFields@ was added to +-- 'FieldRule'. 'Cardinality', 'HandleReferenceRule', and 'FieldCondition' are +-- unchanged by every addition since and so are shared rather than copied; the +-- nested rule types are copied because their @format@ member now refers to the +-- frozen 'PreV02FieldFormat'. Exercised by +-- @okf-core\/test\/fixtures\/profiles\/object-fields-mp8-ep1.dhall@. +data PreObjectProfileFieldRule = PreObjectProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + elementFields :: !(Maybe PreObjectProfileNestedRules), + reference :: !(Maybe HandleReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreObjectProfileNestedRules = PreObjectProfileNestedRules + { required :: ![PreObjectProfileNestedFieldRule], + recommended :: ![PreObjectProfileNestedFieldRule], + optional :: ![PreObjectProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreObjectProfileNestedFieldRule = PreObjectProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreObjectProfileFrontmatterRules = PreObjectProfileFrontmatterRules + { required :: ![PreObjectProfileFieldRule], + recommended :: ![PreObjectProfileFieldRule], + optional :: ![PreObjectProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreObjectProfileSpec = PreObjectProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !PreObjectProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![PreObjectProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreObjectProfileTypeRule = PreObjectProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !PreObjectProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall PreObjectProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete reference-aware descriptor generation, frozen before the +-- @optional@ presence list was added to 'FrontmatterRules' and 'NestedRules'. +-- This is the immediately preceding public descriptor generation: it matches +-- today's shape exactly apart from that third list, so every descriptor written +-- as a record literal against the published schema keeps loading. Exercised by +-- @okf-core\/test\/fixtures\/profiles\/document-references-ep3.dhall@. +data ReferenceProfileFieldRule = ReferenceProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + elementFields :: !(Maybe ReferenceProfileNestedRules), + reference :: !(Maybe HandleReferenceRule), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ReferenceProfileNestedRules = ReferenceProfileNestedRules + { required :: ![ReferenceProfileNestedFieldRule], + recommended :: ![ReferenceProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ReferenceProfileNestedFieldRule = ReferenceProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ReferenceProfileFrontmatterRules = ReferenceProfileFrontmatterRules + { required :: ![ReferenceProfileFieldRule], + recommended :: ![ReferenceProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ReferenceProfileSpec = ReferenceProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !ReferenceProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![ReferenceProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ReferenceProfileTypeRule = ReferenceProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !ReferenceProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall ReferenceProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete condition-aware descriptor generation, frozen before +-- top-level document-reference policies were added. +data ConditionalProfileFieldRule = ConditionalProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + elementFields :: !(Maybe ConditionalProfileNestedRules), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ConditionalProfileNestedRules = ConditionalProfileNestedRules + { required :: ![ConditionalProfileNestedFieldRule], + recommended :: ![ConditionalProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ConditionalProfileNestedFieldRule = ConditionalProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + when :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ConditionalProfileFrontmatterRules = ConditionalProfileFrontmatterRules + { required :: ![ConditionalProfileFieldRule], + recommended :: ![ConditionalProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ConditionalProfileSpec = ConditionalProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !ConditionalProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![ConditionalProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data ConditionalProfileTypeRule = ConditionalProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !ConditionalProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall ConditionalProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete bounded-nested descriptor generation, frozen before +-- same-scope field conditions were added. This is the immediately preceding +-- public descriptor generation. +data NestedProfileFieldRule = NestedProfileFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat), + elementFields :: !(Maybe NestedProfileRules) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data NestedProfileRules = NestedProfileRules + { required :: ![NestedProfileNestedFieldRule], + recommended :: ![NestedProfileNestedFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data NestedProfileNestedFieldRule = NestedProfileNestedFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data NestedProfileFrontmatterRules = NestedProfileFrontmatterRules + { required :: ![NestedProfileFieldRule], + recommended :: ![NestedProfileFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data NestedProfileSpec = NestedProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !NestedProfileFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![NestedProfileTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data NestedProfileTypeRule = NestedProfileTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !NestedProfileFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall NestedProfileTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The complete EP-4 field rule, frozen before one-level nested records were +-- added. This is the immediately preceding public descriptor generation. +data FormatFieldRule = FormatFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe PreV02FieldFormat) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data FormatFrontmatterRules = FormatFrontmatterRules + { required :: ![FormatFieldRule], + recommended :: ![FormatFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data FormatProfileSpec = FormatProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !FormatFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![FormatTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data FormatTypeRule = FormatTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !FormatFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall FormatTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The EP-3 field rule, frozen before named formats were added. +data CardinalityFieldRule = CardinalityFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data CardinalityFrontmatterRules = CardinalityFrontmatterRules + { required :: ![CardinalityFieldRule], + recommended :: ![CardinalityFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The complete EP-3 profile shape, frozen before named formats were added. +data CardinalityProfileSpec = CardinalityProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !CardinalityFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![CardinalityTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data CardinalityTypeRule = CardinalityTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !CardinalityFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall CardinalityTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The EP-2 field rule, frozen before cardinality was added. +data VocabularyFieldRule = VocabularyFieldRule + { field :: !Text, + description :: !(Maybe Text), + allowedValues :: ![Text] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data VocabularyFrontmatterRules = VocabularyFrontmatterRules + { required :: ![VocabularyFieldRule], + recommended :: ![VocabularyFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The EP-2 profile shape, frozen before cardinality was added. +data VocabularyProfileSpec = VocabularyProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !VocabularyFrontmatterRules, + allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + types :: ![VocabularyTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data VocabularyTypeRule = VocabularyTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !VocabularyFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall VocabularyTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | A field rule from either self-documenting schema generation, before value +-- vocabularies were added. +data PreviousFieldRule = PreviousFieldRule + { field :: !Text, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data PreviousFrontmatterRules = PreviousFrontmatterRules + { required :: ![PreviousFieldRule], + recommended :: ![PreviousFieldRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | The type-aware shape from EP-1, frozen before vocabularies and field-name +-- closure were added. +data TypeAwareProfileSpec = TypeAwareProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !PreviousFrontmatterRules, + allowUnknownTypes :: !Bool, + idField :: !(Maybe Text), + types :: ![TypeAwareTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data TypeAwareTypeRule = TypeAwareTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + frontmatter :: !PreviousFrontmatterRules, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall TypeAwareTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | The self-documenting profile shape published immediately before +-- type-specific frontmatter rules. It is frozen as a compatibility decoder in +-- exactly the same way as the older 0.2.x shape below. +data DescribedProfileSpec = DescribedProfileSpec + { name :: !Text, + description :: !(Maybe Text), + okfVersion :: !Text, + frontmatter :: !PreviousFrontmatterRules, + allowUnknownTypes :: !Bool, + idField :: !(Maybe Text), + types :: ![DescribedTypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data DescribedTypeRule = DescribedTypeRule + { type_ :: !Text, + description :: !(Maybe Text), + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text], + idPrefix :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +instance FromDhall DescribedTypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +emptyFrontmatterRules :: FrontmatterRules +emptyFrontmatterRules = FrontmatterRules {required = [], recommended = [], optional = []} + +upgradePrePathProfileFrontmatter :: PrePathProfileFrontmatterRules -> FrontmatterRules +upgradePrePathProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = map upgradeField (previous ^. #optional) + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = rule ^. #format, + elementFields = upgradeNestedRules <$> rule ^. #elementFields, + objectFields = upgradeNestedRules <$> rule ^. #objectFields, + reference = rule ^. #reference, + path = Nothing, + when = rule ^. #when + } + upgradeNestedRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = map upgradeNestedField (rules ^. #optional) + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = rule ^. #format, + path = Nothing, + when = rule ^. #when + } + +upgradePreActorProfileFrontmatter :: PreActorProfileFrontmatterRules -> FrontmatterRules +upgradePreActorProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = map upgradeField (previous ^. #optional) + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = upgradeNestedRules <$> rule ^. #elementFields, + objectFields = upgradeNestedRules <$> rule ^. #objectFields, + reference = rule ^. #reference, + path = Nothing, + when = rule ^. #when + } + upgradeNestedRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = map upgradeNestedField (rules ^. #optional) + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + path = Nothing, + when = rule ^. #when + } + +upgradePreObjectProfileFrontmatter :: PreObjectProfileFrontmatterRules -> FrontmatterRules +upgradePreObjectProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = map upgradeField (previous ^. #optional) + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = upgradeNestedRules <$> rule ^. #elementFields, + objectFields = Nothing, + reference = rule ^. #reference, + path = Nothing, + when = rule ^. #when + } + upgradeNestedRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = map upgradeNestedField (rules ^. #optional) + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + path = Nothing, + when = rule ^. #when + } + +upgradeReferenceProfileFrontmatter :: ReferenceProfileFrontmatterRules -> FrontmatterRules +upgradeReferenceProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = upgradeNestedRules <$> rule ^. #elementFields, + objectFields = Nothing, + reference = rule ^. #reference, + path = Nothing, + when = rule ^. #when + } + upgradeNestedRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = [] + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + path = Nothing, + when = rule ^. #when + } + +upgradePreviousFrontmatter :: PreviousFrontmatterRules -> FrontmatterRules +upgradePreviousFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = [], + cardinality = Any, + format = Nothing, + elementFields = Nothing, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = Nothing + } + +upgradeConditionalProfileFrontmatter :: ConditionalProfileFrontmatterRules -> FrontmatterRules +upgradeConditionalProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = upgradeNestedRules <$> rule ^. #elementFields, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = rule ^. #when + } + upgradeNestedRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = [] + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + path = Nothing, + when = rule ^. #when + } + +upgradeNestedProfileFrontmatter :: NestedProfileFrontmatterRules -> FrontmatterRules +upgradeNestedProfileFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = upgradeNestedProfileRules <$> rule ^. #elementFields, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = Nothing + } + upgradeNestedProfileRules rules = + NestedRules + { required = map upgradeNestedField (rules ^. #required), + recommended = map upgradeNestedField (rules ^. #recommended), + optional = [] + } + upgradeNestedField rule = + NestedFieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + path = Nothing, + when = Nothing + } + +upgradeFormatFrontmatter :: FormatFrontmatterRules -> FrontmatterRules +upgradeFormatFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = upgradePreV02FieldFormat <$> rule ^. #format, + elementFields = Nothing, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = Nothing + } + +upgradeCardinalityFrontmatter :: CardinalityFrontmatterRules -> FrontmatterRules +upgradeCardinalityFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = Nothing, + elementFields = Nothing, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = Nothing + } + +upgradeVocabularyFrontmatter :: VocabularyFrontmatterRules -> FrontmatterRules +upgradeVocabularyFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended), + optional = [] + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = Any, + format = Nothing, + elementFields = Nothing, + objectFields = Nothing, + reference = Nothing, + path = Nothing, + when = Nothing + } + +-- | Lift the generation frozen before @requireBundleVersion@ forward. Every rule +-- record is shared with today's schema, so this copies members across and +-- supplies the one no-op default: a descriptor that predates the member demands +-- nothing of its bundle's version declaration, which is what it meant when it +-- was written. +upgradePreBundleVersionProfile :: PreBundleVersionProfileSpec -> ProfileSpec +upgradePreBundleVersionProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = previous ^. #frontmatter, + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = previous ^. #types + } + +upgradePrePathProfile :: PrePathProfileSpec -> ProfileSpec +upgradePrePathProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradePrePathProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradePrePathProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradePreActorProfile :: PreActorProfileSpec -> ProfileSpec +upgradePreActorProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradePreActorProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradePreActorProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradePreObjectProfile :: PreObjectProfileSpec -> ProfileSpec +upgradePreObjectProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradePreObjectProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradePreObjectProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeReferenceProfile :: ReferenceProfileSpec -> ProfileSpec +upgradeReferenceProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeReferenceProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeReferenceProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeConditionalProfile :: ConditionalProfileSpec -> ProfileSpec +upgradeConditionalProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeConditionalProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeConditionalProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeNestedProfile :: NestedProfileSpec -> ProfileSpec +upgradeNestedProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeNestedProfileFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeNestedProfileFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeFormatProfile :: FormatProfileSpec -> ProfileSpec +upgradeFormatProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeFormatFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeFormatFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeCardinalityProfile :: CardinalityProfileSpec -> ProfileSpec +upgradeCardinalityProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeCardinalityFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeCardinalityFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeVocabularyProfile :: VocabularyProfileSpec -> ProfileSpec +upgradeVocabularyProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradeVocabularyFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = previous ^. #allowUnknownFields, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradeVocabularyFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeTypeAwareProfile :: TypeAwareProfileSpec -> ProfileSpec +upgradeTypeAwareProfile previous = + ProfileSpec + { name = previous ^. #name, + description = previous ^. #description, + okfVersion = previous ^. #okfVersion, + frontmatter = upgradePreviousFrontmatter (previous ^. #frontmatter), + allowUnknownTypes = previous ^. #allowUnknownTypes, + allowUnknownFields = True, + idField = previous ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (previous ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = upgradePreviousFrontmatter (rule ^. #frontmatter), + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +upgradeDescribedProfile :: DescribedProfileSpec -> ProfileSpec +upgradeDescribedProfile described = + ProfileSpec + { name = described ^. #name, + description = described ^. #description, + okfVersion = described ^. #okfVersion, + frontmatter = upgradePreviousFrontmatter (described ^. #frontmatter), + allowUnknownTypes = described ^. #allowUnknownTypes, + allowUnknownFields = True, + idField = described ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (described ^. #types) + } + where + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = rule ^. #description, + frontmatter = emptyFrontmatterRules, + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +-- | Lift a 0.2.x profile into the current shape by attaching no descriptions +-- and empty type-specific frontmatter. +upgradeLegacyProfile :: LegacyProfileSpec -> ProfileSpec +upgradeLegacyProfile legacy = + ProfileSpec + { name = legacy ^. #name, + description = Nothing, + okfVersion = legacy ^. #okfVersion, + frontmatter = + FrontmatterRules + { required = map undocumented (legacy ^. #frontmatter . #required), + recommended = map undocumented (legacy ^. #frontmatter . #recommended), + optional = [] + }, + allowUnknownTypes = legacy ^. #allowUnknownTypes, + allowUnknownFields = True, + idField = legacy ^. #idField, + requireBundleVersion = Nothing, + types = map upgradeRule (legacy ^. #types) + } + where + undocumented key = FieldRule {field = key, description = Nothing, allowedValues = [], cardinality = Any, format = Nothing, elementFields = Nothing, objectFields = Nothing, reference = Nothing, path = Nothing, when = Nothing} + upgradeRule rule = + TypeRule + { type_ = rule ^. #type_, + description = Nothing, + frontmatter = emptyFrontmatterRules, + pathPattern = rule ^. #pathPattern, + resourceScheme = rule ^. #resourceScheme, + requireSchemaSection = rule ^. #requireSchemaSection, + schemaColumns = rule ^. #schemaColumns, + idPrefix = rule ^. #idPrefix + } + +-- | Load and decode a Dhall profile descriptor from a file path. Any evaluation +-- or decoding failure is captured as a human-readable 'Left'. +-- +-- The pre-bundle-version shape, pre-path shape, pre-actor shape, pre-object +-- shape, reference-aware shape, +-- condition-aware shape, bounded-nested shape, EP-4 +-- format shape, EP-3 cardinality shape, EP-2 vocabulary shape, type-aware EP-1 +-- shape, self-documenting shape, and okf 0.2.x shape are accepted by frozen +-- fallback decoders and upgraded +-- with their no-op defaults. When every decoder fails, the /current/ decoder's +-- error is reported. +loadProfileFile :: FilePath -> IO (Either Text ProfileSpec) +loadProfileFile path = do + current <- tryDecode (Dhall.inputFile auto path) + case current of + Right spec -> pure (Right spec) + -- Only the current decoder's error is kept. An author wants to know how + -- their descriptor differs from today's schema, not from a retired one. + Left currentError -> maybe (Left currentError) Right <$> firstFrozen frozenDecoders + where + -- Newest generation first. Each entry looks identical but is inferred at a + -- distinct result type, fixed by the upgrade function it names; @auto@ then + -- picks that generation's decoder. Adding a generation is one line here. + frozenDecoders :: [IO (Maybe ProfileSpec)] + frozenDecoders = + [ attempt upgradePreBundleVersionProfile, + attempt upgradePrePathProfile, + attempt upgradePreActorProfile, + attempt upgradePreObjectProfile, + attempt upgradeReferenceProfile, + attempt upgradeConditionalProfile, + attempt upgradeNestedProfile, + attempt upgradeFormatProfile, + attempt upgradeCardinalityProfile, + attempt upgradeVocabularyProfile, + attempt upgradeTypeAwareProfile, + attempt upgradeDescribedProfile, + attempt upgradeLegacyProfile + ] + + -- Short-circuiting, so a descriptor that decodes at the first frozen + -- generation costs one extra parse rather than thirteen. + firstFrozen :: [IO (Maybe ProfileSpec)] -> IO (Maybe ProfileSpec) + firstFrozen [] = pure Nothing + firstFrozen (decoder : remaining) = + decoder >>= \case + Just spec -> pure (Just spec) + Nothing -> firstFrozen remaining + + attempt :: (FromDhall a) => (a -> ProfileSpec) -> IO (Maybe ProfileSpec) + attempt upgrade = either (const Nothing) (Just . upgrade) <$> tryDecode (Dhall.inputFile auto path) + + tryDecode :: IO a -> IO (Either Text a) + tryDecode action = + (Right <$> action) + `catch` \(exception :: SomeException) -> pure (Left (Text.pack (show exception))) + +-- | Does an already-evaluated Dhall expression decode as a profile? Tries the +-- current schema, then the pre-bundle-version, pre-path, pre-actor, pre-object, +-- reference-aware, +-- condition-aware, bounded-nested, EP-4, EP-3, EP-2, EP-1, self-documenting, and +-- okf 0.2.x schemas, so the published @okf-profiles@ package still enumerates. +-- Uses 'Dhall.rawInput', which normalizes and runs the decoder's extractor +-- without throwing, which is what lets registry enumeration be pure. +decodeProfileExpr :: Expr Src Void -> Maybe ProfileSpec +decodeProfileExpr expression = + Dhall.rawInput Dhall.auto expression + <|> fmap upgradePreBundleVersionProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradePrePathProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradePreActorProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradePreObjectProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeReferenceProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeConditionalProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeNestedProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeFormatProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeCardinalityProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeVocabularyProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeTypeAwareProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeDescribedProfile (Dhall.rawInput Dhall.auto expression) + <|> fmap upgradeLegacyProfile (Dhall.rawInput Dhall.auto expression) + +-- | The description a profile attaches to a frontmatter key, looking in +-- @required@ first, then @recommended@, then @optional@. 'Nothing' when the key +-- is undocumented or absent from the profile entirely. +profileFieldDescription :: ProfileSpec -> Text -> Maybe Text +profileFieldDescription spec key = + case [rule | rule <- rules, rule ^. #field == key] of + (rule : _) -> rule ^. #description + [] -> Nothing + where + rules = + spec ^. #frontmatter . #required + <> spec ^. #frontmatter . #recommended + <> spec ^. #frontmatter . #optional + +-- | A malformed profile definition. The optional type is absent for profile +-- scope and present for a type-specific scope. The list name is @required@, +-- @recommended@, or @optional@. +data ProfileDefinitionError + = DuplicateTypeRule Text + | DuplicateFieldRule (Maybe Text) Text Text + | ConflictingFieldRequirement (Maybe Text) Text + | UnsatisfiableVocabulary (Maybe Text) Text [Text] [Text] + | ConflictingCardinality (Maybe Text) Text Cardinality Cardinality + | ElementFieldsRequireList (Maybe Text) FieldPath Cardinality + | InvalidFormatParameter FieldPath FieldFormat Text + | ConflictingFieldFormat FieldPath FieldFormat FieldFormat + | EmptyConditionValues (Maybe Text) FieldPath FieldPath + | ConditionFieldNotDeclared (Maybe Text) FieldPath FieldPath + | ConditionFieldNotScalar (Maybe Text) FieldPath FieldPath Cardinality + | ConditionFieldOpenVocabulary (Maybe Text) FieldPath FieldPath + | ConditionFieldHasUnreachableValues (Maybe Text) FieldPath FieldPath [Text] [Text] + | SelfConditionalField (Maybe Text) FieldPath + | InvalidReferencePrefix (Maybe Text) FieldPath Text + | ReferencePrefixNotDeclared (Maybe Text) FieldPath Text + | ReferenceRequiresIdField (Maybe Text) FieldPath + | InvalidExternalReferenceScheme (Maybe Text) FieldPath Text + | ConflictingReferencePrefix Text FieldPath Text Text + | ReferenceWithFormat (Maybe Text) FieldPath FieldFormat + | -- | an @optional@ rule carries a @when@ condition, which gates only presence + -- and is therefore dead: an optional rule has no presence check at all + OptionalFieldWithCondition (Maybe Text) FieldPath + | -- | a rule declares @objectFields@ alongside an explicit scalar or list + -- cardinality; an object is neither, so the pairing cannot be satisfied + ObjectFieldsRequireObjectShape (Maybe Text) FieldPath Cardinality + | -- | one rule declares both a document-handle policy and a path policy; + -- a value cannot be resolved as both a handle and a path + PathReferenceWithHandleReference (Maybe Text) FieldPath + | -- | @okfVersion@ is not @\.\@ + InvalidProfileOkfVersion Text + | -- | @okfVersion@ names a major version okf does not implement, so okf cannot + -- know which of its rules still hold + ProfileOkfVersionNotUnderstood Text + | -- | @requireBundleVersion@ is not @\.\@, so no bundle + -- declaration could ever be compared against it + InvalidRequiredBundleVersion Text + | -- | a required or recommended rule names a key the declared version + -- supersedes (scope, path, declared version, version that superseded the key) + FieldSupersededInOkfVersion (Maybe Text) FieldPath Text Text + | -- | a rule names a value format introduced after the declared version + -- (scope, path, format, declared version, version that introduced the format) + FormatRequiresOkfVersion (Maybe Text) FieldPath FieldFormat Text Text + deriving stock (Generic, Eq, Ord, Show) + +-- | Whether a 'PresenceClause' demands a key or merely recommends it. There is +-- deliberately no @OptionalField@ constructor: an optional key is encoded as an +-- 'EffectiveFieldRule' with /no/ presence clauses at all. +data FieldRequirement = RecommendedField | RequiredField + deriving stock (Generic, Eq, Ord, Show) + +-- | One reason a key may have to be present, optionally gated by a condition on +-- another same-scope key. Abstract: read it with 'presenceClauseRequirement' and +-- 'presenceClauseCondition'. +data PresenceClause = PresenceClause + { requirement :: !FieldRequirement, + condition :: !(Maybe FieldCondition) + } + deriving stock (Generic, Eq, Show) + +-- | Everything that actually applies to one frontmatter key for one concept +-- type: the profile-scope declaration merged with the type-scope one per +-- [ADR 5](docs/adr/5-compile-profile-rules-before-validation.md). Abstract: read +-- it with the @fieldRule*@ accessors below, never by pattern matching, so that +-- later profile features can extend it without breaking consumers. +data EffectiveFieldRule = EffectiveFieldRule + { presenceClauses :: ![PresenceClause], + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + elementFields :: !(Maybe (Map Text EffectiveFieldRule)), + objectFields :: !(Maybe (Map Text EffectiveFieldRule)), + reference :: !(Maybe HandleReferenceRule), + path :: !(Maybe PathReferenceRule) + } + deriving stock (Generic, Eq, Show) + +-- | The stable lowercase display name for a cardinality: @any@, @scalar@, +-- @list@, or @object@. These are the names the CLI prints and the names +-- generated profile documentation uses, so a reader who has seen one recognizes +-- the other. @object@ is also the word the CLI already prints for an actual +-- mapping value, so a cardinality-mismatch message reads coherently. +renderCardinalityName :: Cardinality -> Text +renderCardinalityName = \case + Any -> "any" + Scalar -> "scalar" + List -> "list" + Object -> "object" + +-- | The stable display name for a named format: @rfc3339-utc@, @date@, @uri@, +-- @uri-with-scheme(SCHEME)@, @document-handle(PREFIX)@, @actor@, +-- @human-actor@, @integer@, @non-negative-integer@, or @boolean@. As with +-- 'renderCardinalityName', this vocabulary is shared between the CLI and +-- generated documentation and must not drift between them. +renderFieldFormatName :: FieldFormat -> Text +renderFieldFormatName = \case + Rfc3339Utc -> "rfc3339-utc" + Date -> "date" + Uri -> "uri" + UriWithScheme scheme -> "uri-with-scheme(" <> scheme <> ")" + DocumentHandle prefix -> "document-handle(" <> prefix <> ")" + Actor -> "actor" + HumanActor -> "human-actor" + Integer -> "integer" + NonNegativeInteger -> "non-negative-integer" + Boolean -> "boolean" + +-- | The presence clauses that govern whether this key must be present, in the +-- order the profile declared them. An __empty list means the key is optional__: +-- it is fully validated whenever it is present and never reported when absent, +-- in any validation mode. A clause with 'RequiredField' is always checked; a +-- clause with 'RecommendedField' is checked only under +-- 'Okf.Validation.StrictAuthoring'. A clause carrying a 'FieldCondition' applies +-- only when that condition holds for the document being checked. +fieldRulePresenceClauses :: EffectiveFieldRule -> [PresenceClause] +fieldRulePresenceClauses rule = rule ^. #presenceClauses + +-- | Prose documenting the key, merged across profile and type scope with +-- type-level prose winning. Purely documentary: it is never checked against a +-- document and can never produce a 'ProfileViolation'. +fieldRuleDescription :: EffectiveFieldRule -> Maybe Text +fieldRuleDescription rule = rule ^. #description + +-- | The closed vocabulary of permitted textual values. An __empty list means +-- unconstrained__, not "no value is permitted". +fieldRuleAllowedValues :: EffectiveFieldRule -> [Text] +fieldRuleAllowedValues rule = rule ^. #allowedValues + +-- | Whether the key must be a single value, a non-empty list, or either. +fieldRuleCardinality :: EffectiveFieldRule -> Cardinality +fieldRuleCardinality rule = rule ^. #cardinality + +-- | The named textual format constraining present values, if any. +fieldRuleFormat :: EffectiveFieldRule -> Maybe FieldFormat +fieldRuleFormat rule = rule ^. #format + +-- | The document-reference policy for this key, if any. +fieldRuleReference :: EffectiveFieldRule -> Maybe HandleReferenceRule +fieldRuleReference rule = rule ^. #reference + +-- | The path-valued policy for this key, if any. Distinct from +-- 'fieldRuleReference': a handle resolves against the bundle's document-ID +-- index, a path against its concept tree. A rule never carries both — compiling +-- one that does is a 'PathReferenceWithHandleReference' definition error — so a +-- consumer can read whichever is present without disambiguating. +-- +-- Unlike 'fieldRuleReference' this can be present on a rule taken from +-- 'fieldRuleElementFields' or 'fieldRuleObjectFields', because +-- @sources[].resource@ is the field the policy exists for. +fieldRulePath :: EffectiveFieldRule -> Maybe PathReferenceRule +fieldRulePath rule = rule ^. #path + +-- | Rules for the flat object stored in each element of a list-valued key, +-- keyed by nested key name, or 'Nothing' when the key declares no nested shape. +-- Nested rules are depth-bounded: a nested rule never itself has element fields, +-- so 'fieldRuleElementFields' on a value taken from this map is always +-- 'Nothing'. +fieldRuleElementFields :: EffectiveFieldRule -> Maybe (Map Text EffectiveFieldRule) +fieldRuleElementFields rule = rule ^. #elementFields + +-- | Rules for the members of the mapping stored at this key, keyed by member +-- name, or 'Nothing' when the key declares no object shape. Like +-- 'fieldRuleElementFields' this is depth-bounded: a value taken from this map +-- always has 'Nothing' for both nested accessors. A rule may declare both, which +-- means either spelling of the value is accepted and both are checked against +-- the same member rules. +fieldRuleObjectFields :: EffectiveFieldRule -> Maybe (Map Text EffectiveFieldRule) +fieldRuleObjectFields rule = rule ^. #objectFields + +-- | Whether this clause demands the key or merely recommends it. +presenceClauseRequirement :: PresenceClause -> FieldRequirement +presenceClauseRequirement clause = clause ^. #requirement + +-- | The same-scope predicate gating this clause, or 'Nothing' when it always +-- applies. +presenceClauseCondition :: PresenceClause -> Maybe FieldCondition +presenceClauseCondition clause = clause ^. #condition + +-- | A raw profile whose authoring contradictions have been rejected and whose +-- effective profile-plus-type frontmatter rules have been precomputed. +data CompiledProfile = CompiledProfile + { spec :: !ProfileSpec, + baseRules :: !(Map Text EffectiveFieldRule), + rulesByType :: !(Map Text (Map Text EffectiveFieldRule)), + -- | @requireBundleVersion@ already parsed, so 'validateProfileVersion' never + -- re-parses and cannot disagree with what compilation accepted. + requiredBundleVersion :: !(Maybe OkfVersion) + } + deriving stock (Generic, Eq, Show) + +compiledProfileSpec :: CompiledProfile -> ProfileSpec +compiledProfileSpec compiled = compiled ^. #spec + +-- | The minimum OKF version the profile requires its bundle to declare, already +-- parsed. 'Nothing' when the profile requires nothing, which is the default and +-- the case for almost every profile. +compiledProfileRequiredBundleVersion :: CompiledProfile -> Maybe OkfVersion +compiledProfileRequiredBundleVersion compiled = compiled ^. #requiredBundleVersion + +-- | The concept @type@ strings the profile declares, in the order the descriptor +-- declares them. Declaration order is the author's and is preserved because +-- documentation and display should follow it rather than an alphabetical +-- reordering. +compiledProfileTypeNames :: CompiledProfile -> [Text] +compiledProfileTypeNames compiled = + [rule ^. #type_ | rule <- compiledProfileSpec compiled ^. #types] + +-- | The rules that apply to every document, whatever its type, keyed by +-- frontmatter key name. +compiledProfileBaseRules :: CompiledProfile -> Map Text EffectiveFieldRule +compiledProfileBaseRules compiled = compiled ^. #baseRules + +-- | The rules that apply to a document of the given @type@: the profile-scope +-- rules merged with that type's own. A type the profile does not declare falls +-- back to the profile-scope rules alone, because a profile with +-- @allowUnknownTypes = True@ still applies its profile-wide expectations to a +-- document whose type it does not recognize. +compiledProfileRulesForType :: CompiledProfile -> Text -> Map Text EffectiveFieldRule +compiledProfileRulesForType = effectiveRulesForType + +compileProfile :: ProfileSpec -> Either (NonEmpty ProfileDefinitionError) CompiledProfile +compileProfile rawSpec = + case definitionErrors of + firstError : remainingErrors -> Left (firstError :| remainingErrors) + [] -> + Right + CompiledProfile + { spec = rawSpec, + baseRules, + rulesByType = + Map.fromList + [ (rule ^. #type_, mergeRules baseRules (compileRules (rule ^. #frontmatter))) + | rule <- rawSpec ^. #types + ], + -- Safe here and only here: 'requiredBundleVersionErrors' is one of + -- the checks 'definitionErrors' collects, so reaching this branch + -- means the value parsed. + requiredBundleVersion = rawSpec ^. #requireBundleVersion >>= parseOkfVersion + } + where + baseRules = compileRules (rawSpec ^. #frontmatter) + typeNames = map (^. #type_) (rawSpec ^. #types) + definitionErrors = + List.sortOn definitionErrorKey $ + map DuplicateTypeRule (duplicates typeNames) + <> scopeErrors Nothing (rawSpec ^. #frontmatter) + <> concat + [ scopeErrors (Just (rule ^. #type_)) (rule ^. #frontmatter) + | rule <- rawSpec ^. #types + ] + <> vocabularyErrors + <> cardinalityErrors + <> nestedCardinalityErrors + <> objectCardinalityErrors + <> formatParameterErrors + <> conflictingFormatErrors + <> conditionDefinitionErrors + <> referenceDefinitionErrors + <> versionErrors + <> requiredBundleVersionErrors + + definitionErrorKey = \case + DuplicateTypeRule ctype -> (1 :: Int, ctype, 0 :: Int, "", 0 :: Int) + DuplicateFieldRule scope listName key -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, listKey listName, key, 0) + ConflictingFieldRequirement scope key -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 2, key, 0) + UnsatisfiableVocabulary scope key _ _ -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 3, key, 0) + ConflictingCardinality scope key _ _ -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 4, key, 0) + ElementFieldsRequireList scope path cardinality -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 4, renderFieldPathKey path, fromEnum (cardinality == Scalar)) + InvalidFormatParameter path fieldFormat parameter -> + (2, renderFieldPathKey path, 5, Text.pack (show fieldFormat), Text.length parameter) + ConflictingFieldFormat path profileFormat typeFormat -> + (2, renderFieldPathKey path, 6, Text.pack (show profileFormat), fromEnum (profileFormat == typeFormat)) + EmptyConditionValues scope target source -> conditionErrorKey scope target source 7 + ConditionFieldNotDeclared scope target source -> conditionErrorKey scope target source 8 + ConditionFieldNotScalar scope target source cardinality -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 9, renderFieldPathKey target <> ":" <> renderFieldPathKey source, fromEnum (cardinality == Scalar)) + ConditionFieldOpenVocabulary scope target source -> conditionErrorKey scope target source 10 + ConditionFieldHasUnreachableValues scope target source _ _ -> conditionErrorKey scope target source 11 + SelfConditionalField scope target -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 12, renderFieldPathKey target, 0) + InvalidReferencePrefix scope target prefix -> referenceErrorKey scope target 13 prefix + ReferencePrefixNotDeclared scope target prefix -> referenceErrorKey scope target 14 prefix + ReferenceRequiresIdField scope target -> referenceErrorKey scope target 15 "" + InvalidExternalReferenceScheme scope target scheme -> referenceErrorKey scope target 16 scheme + ConflictingReferencePrefix ctype target profilePrefix typePrefix -> + (1, ctype, 17, renderFieldPathKey target <> ":" <> profilePrefix, Text.length typePrefix) + ReferenceWithFormat scope target fieldFormat -> referenceErrorKey scope target 18 (Text.pack (show fieldFormat)) + OptionalFieldWithCondition scope target -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 19, renderFieldPathKey target, 0) + ObjectFieldsRequireObjectShape scope fieldPath cardinality -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 20, renderFieldPathKey fieldPath, fromEnum (cardinality == Scalar)) + PathReferenceWithHandleReference scope target -> referenceErrorKey scope target 21 "" + -- The two version-parse errors are profile-wide rather than scoped, and + -- rank below every scope rank: if the declared version is unreadable, every + -- version-derived error below is downstream noise and the reader should see + -- the cause first. Nothing constrains the first component to be + -- non-negative. + InvalidProfileOkfVersion rawVersion -> (-1, rawVersion, 0, "", 0) + ProfileOkfVersionNotUnderstood rawVersion -> (-1, rawVersion, 1, "", 0) + InvalidRequiredBundleVersion rawVersion -> (-1, rawVersion, 2, "", 0) + FieldSupersededInOkfVersion scope path _declared supersededIn -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 23, renderFieldPathKey path <> ":" <> supersededIn, 0) + FormatRequiresOkfVersion scope path fieldFormat _declared introducedIn -> + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, 24, renderFieldPathKey path <> ":" <> introducedIn, Text.length (Text.pack (show fieldFormat))) + + scopeKey Nothing = (0, "") + scopeKey (Just ctype) = (1, ctype) + listKey "required" = 0 + listKey _ = 1 + conditionErrorKey scope target source rank = + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, rank, renderFieldPathKey target <> ":" <> renderFieldPathKey source, 0) + referenceErrorKey scope target rank detail = + let (scopeRank, typeName) = scopeKey scope + in (scopeRank, typeName, rank, renderFieldPathKey target <> ":" <> detail, 0) + + scopeErrors scope FrontmatterRules {required, recommended, optional} = + [DuplicateFieldRule scope "required" key | key <- duplicates (map (^. #field) required)] + <> [DuplicateFieldRule scope "recommended" key | key <- duplicates (map (^. #field) recommended)] + <> [DuplicateFieldRule scope "optional" key | key <- duplicates (map (^. #field) optional)] + <> [ ConflictingFieldRequirement scope key + | key <- presenceListCollisions (map (^. #field) required) (map (^. #field) recommended) (map (^. #field) optional) + ] + <> concatMap (nestedScopeErrors scope) (required <> recommended <> optional) + + nestedScopeErrors scope parentRule = + concatMap oneNestedRuleSet (declaredNestedRuleSets parentRule) + where + oneNestedRuleSet NestedRules {required, recommended, optional} = + let qualify key = parentRule ^. #field <> "." <> key + in [DuplicateFieldRule scope "nested required" (qualify key) | key <- duplicates (map (^. #field) required)] + <> [DuplicateFieldRule scope "nested recommended" (qualify key) | key <- duplicates (map (^. #field) recommended)] + <> [DuplicateFieldRule scope "nested optional" (qualify key) | key <- duplicates (map (^. #field) optional)] + <> [ ConflictingFieldRequirement scope (qualify key) + | key <- presenceListCollisions (map (^. #field) required) (map (^. #field) recommended) (map (^. #field) optional) + ] + + -- One key classified by more than one presence list at a single scope. The + -- profile cannot say both "always check for this" and "never check for + -- this", so any pairing is a definition error rather than a precedence rule. + presenceListCollisions requiredKeys recommendedKeys optionalKeys = + List.nub . List.sort . concat $ + [ List.intersect requiredKeys recommendedKeys, + List.intersect requiredKeys optionalKeys, + List.intersect recommendedKeys optionalKeys + ] + + duplicates = mapMaybe duplicateHead . List.group . List.sort + duplicateHead (candidate : _ : _) = Just candidate + duplicateHead _ = Nothing + + vocabularyErrors = + [ UnsatisfiableVocabulary (Just (rule ^. #type_)) key profileValues typeValues + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + let profileValues = profileRule ^. #allowedValues + typeValues = typeRule ^. #allowedValues, + not (null profileValues), + not (null typeValues), + null (mergeVocabulary profileValues typeValues) + ] + <> [ UnsatisfiableVocabulary (Just (rule ^. #type_)) (parentKey <> "." <> nestedKey) profileValues typeValues + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + (profileNested, typeNested) <- pairedNestedRuleMaps profileRule typeRule, + (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), + let profileValues = profileNestedRule ^. #allowedValues + typeValues = typeNestedRule ^. #allowedValues, + not (null profileValues), + not (null typeValues), + null (mergeVocabulary profileValues typeValues) + ] + + cardinalityErrors = + [ ConflictingCardinality (Just (rule ^. #type_)) key profileCardinality typeCardinality + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + let profileCardinality = profileRule ^. #cardinality + typeCardinality = typeRule ^. #cardinality, + profileCardinality /= Any, + typeCardinality /= Any, + profileCardinality /= typeCardinality + ] + <> [ ConflictingCardinality (Just (rule ^. #type_)) (parentKey <> "." <> nestedKey) profileCardinality typeCardinality + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + (profileNested, typeNested) <- pairedNestedRuleMaps profileRule typeRule, + (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), + let profileCardinality = profileNestedRule ^. #cardinality + typeCardinality = typeNestedRule ^. #cardinality, + profileCardinality /= Any, + typeCardinality /= Any, + profileCardinality /= typeCardinality + ] + + nestedCardinalityErrors = + [ ElementFieldsRequireList scope (topLevelFieldPath (fieldRule ^. #field)) Scalar + | (scope, rules) <- scopedFrontmatterRules, + fieldRule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + isJust (fieldRule ^. #elementFields), + fieldRule ^. #cardinality == Scalar + ] + + -- The mirror image: @objectFields@ says the value is a mapping, and neither + -- an explicit @scalar@ nor an explicit @list@ can be one. + objectCardinalityErrors = + [ ObjectFieldsRequireObjectShape scope (topLevelFieldPath (fieldRule ^. #field)) declared + | (scope, rules) <- scopedFrontmatterRules, + fieldRule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + isJust (fieldRule ^. #objectFields), + let declared = fieldRule ^. #cardinality, + declared == Scalar || declared == List + ] + + scopedFrontmatterRules = + (Nothing, rawSpec ^. #frontmatter) + : [(Just (rule ^. #type_), rule ^. #frontmatter) | rule <- rawSpec ^. #types] + + -- The nested rule sets one raw rule declares: its list-element rules, its + -- object-member rules, or both. Deduplicated because @mk.recordOrList@ + -- deliberately declares the same rules under both names, and a definition + -- error names a path such as @verified.by@ that does not distinguish the two + -- — so without this the same incoherence would be reported twice. + declaredNestedRuleSets rawRule = + List.nub (catMaybes [rawRule ^. #elementFields, rawRule ^. #objectFields]) + + -- The same idea across two scopes: the nested maps a profile-scope rule and + -- a type-scope rule both declare, paired shape with matching shape. Pairing + -- an element map against an object map would compare rules that never meet. + pairedNestedRuleMaps profileRule typeRule = + List.nub + [ (profileNested, typeNested) + | nestedMap <- [(^. #elementFields), (^. #objectFields)], + Just profileNested <- [nestedMap profileRule], + Just typeNested <- [nestedMap typeRule] + ] + + formatParameterErrors = + [ InvalidFormatParameter (topLevelFieldPath (rule ^. #field)) fieldFormat parameter + | rules <- (rawSpec ^. #frontmatter) : map (^. #frontmatter) (rawSpec ^. #types), + rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + Just (fieldFormat, parameter) <- [invalidFormatParameter =<< rule ^. #format] + ] + <> [ InvalidFormatParameter (nestedDefinitionPath (rule ^. #field) (nestedRule ^. #field)) fieldFormat parameter + | rules <- (rawSpec ^. #frontmatter) : map (^. #frontmatter) (rawSpec ^. #types), + rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + nestedRules <- declaredNestedRuleSets rule, + nestedRule <- nestedRules ^. #required <> nestedRules ^. #recommended <> nestedRules ^. #optional, + Just (fieldFormat, parameter) <- [invalidFormatParameter =<< nestedRule ^. #format] + ] + + conflictingFormatErrors = + [ ConflictingFieldFormat (topLevelFieldPath key) profileFormat typeFormat + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (key, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + Just profileFormat <- [profileRule ^. #format], + Just typeFormat <- [typeRule ^. #format], + mergeFieldFormat (Just profileFormat) (Just typeFormat) == Nothing + ] + <> [ ConflictingFieldFormat (nestedDefinitionPath parentKey nestedKey) profileFormat typeFormat + | rule <- rawSpec ^. #types, + let typeRules = compileRules (rule ^. #frontmatter), + (parentKey, (profileRule, typeRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeRules), + (profileNested, typeNested) <- pairedNestedRuleMaps profileRule typeRule, + (nestedKey, (profileNestedRule, typeNestedRule)) <- Map.toAscList (Map.intersectionWith (,) profileNested typeNested), + Just profileFormat <- [profileNestedRule ^. #format], + Just typeFormat <- [typeNestedRule ^. #format], + mergeFieldFormat (Just profileFormat) (Just typeFormat) == Nothing + ] + + conditionDefinitionErrors = + conditionErrors Nothing Nothing (rawSpec ^. #frontmatter) baseRules + <> concat + [ let typeRules = compileRules (rule ^. #frontmatter) + mergedRules = mergeRules baseRules typeRules + in conditionErrors (Just (rule ^. #type_)) Nothing (rule ^. #frontmatter) mergedRules + | rule <- rawSpec ^. #types + ] + + conditionErrors scope parent rules effectiveRules = + concatMap (fieldConditionErrors scope parent effectiveRules) (rules ^. #required <> rules ^. #recommended) + <> [ deadCondition scope parent (rawRule ^. #field) + | rawRule <- rules ^. #optional, + isJust (rawRule ^. #when) + ] + <> List.nub + ( concat + [ concatMap + (fieldConditionErrors scope (Just (rawRule ^. #field)) effectiveNestedRules) + (nestedRules ^. #required <> nestedRules ^. #recommended) + <> [ deadCondition scope (Just (rawRule ^. #field)) (nestedRule ^. #field) + | nestedRule <- nestedRules ^. #optional, + isJust (nestedRule ^. #when) + ] + | rawRule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + let effectiveRule = Map.lookup (rawRule ^. #field) effectiveRules, + (nestedRules, effectiveNestedRules) <- + catMaybes + [ (,) <$> (rawRule ^. #elementFields) <*> (effectiveRule >>= (^. #elementFields)), + (,) <$> (rawRule ^. #objectFields) <*> (effectiveRule >>= (^. #objectFields)) + ] + ] + ) + + -- A condition gates presence, and an optional rule has no presence clause to + -- gate, so the pairing is dead in the descriptor rather than a weaker rule. + deadCondition scope parent key = + OptionalFieldWithCondition + scope + (maybe (topLevelFieldPath key) (\parentKey -> nestedDefinitionPath parentKey key) parent) + + fieldConditionErrors scope parent effectiveRules rawRule = + case rawRule ^. #when of + Nothing -> [] + Just FieldCondition {field = sourceKey, hasValue = conditionValues} -> + let targetKey = rawRule ^. #field + targetPath = maybe (topLevelFieldPath targetKey) (\parentKey -> nestedDefinitionPath parentKey targetKey) parent + sourcePath = maybe (topLevelFieldPath sourceKey) (\parentKey -> nestedDefinitionPath parentKey sourceKey) parent + normalizedValues = deduplicate conditionValues + sourceErrors = + case Map.lookup sourceKey effectiveRules of + Nothing -> [ConditionFieldNotDeclared scope targetPath sourcePath] + Just sourceRule -> + [ ConditionFieldNotScalar scope targetPath sourcePath (sourceRule ^. #cardinality) + | sourceRule ^. #cardinality /= Scalar + ] + <> [ ConditionFieldOpenVocabulary scope targetPath sourcePath + | null (sourceRule ^. #allowedValues) + ] + <> let unreachable = filter (`notElem` sourceRule ^. #allowedValues) normalizedValues + in [ ConditionFieldHasUnreachableValues scope targetPath sourcePath unreachable (sourceRule ^. #allowedValues) + | not (null (sourceRule ^. #allowedValues)), + not (null unreachable) + ] + in [EmptyConditionValues scope targetPath sourcePath | null normalizedValues] + <> [SelfConditionalField scope targetPath | targetKey == sourceKey] + <> sourceErrors + + referenceDefinitionErrors = + List.nub $ + concatMap rawReferenceErrors scopedRules + <> concatMap mergedReferenceErrors (rawSpec ^. #types) + where + declaredPrefixes = mapMaybe (^. #idPrefix) (rawSpec ^. #types) + scopedRules = + (Nothing, rawSpec ^. #frontmatter) + : [(Just (rule ^. #type_), rule ^. #frontmatter) | rule <- rawSpec ^. #types] + + rawReferenceErrors (scope, rules) = + concatMap (fieldReferenceErrors scope) topLevelRules + <> concatMap (fieldPathErrors scope) topLevelRules + -- Path rules are declarable at nested and object scope too, which + -- is where @sources[].resource@ lives, so the walk descends. It + -- hangs on 'declaredNestedRuleSets' rather than iterating + -- @elementFields@ and @objectFields@ separately, because + -- @mk.recordOrList@ declares one rule set under both names and a + -- @FieldPath@ such as @sources.resource@ cannot tell them apart. + <> [ nestedError + | rule <- topLevelRules, + nestedRules <- declaredNestedRuleSets rule, + nestedRule <- nestedRules ^. #required <> nestedRules ^. #recommended <> nestedRules ^. #optional, + nestedError <- + pathPolicyErrors + scope + (nestedDefinitionPath (rule ^. #field) (nestedRule ^. #field)) + (nestedRule ^. #format) + Nothing + (nestedRule ^. #path) + ] + where + topLevelRules = rules ^. #required <> rules ^. #recommended <> rules ^. #optional + + fieldReferenceErrors scope rule = + case rule ^. #reference of + Nothing -> [] + Just policy -> + let path = topLevelFieldPath (rule ^. #field) + prefix = policy ^. #localPrefix + schemes = deduplicateSchemes (policy ^. #externalUriSchemes) + in [InvalidReferencePrefix scope path prefix | not (validDocumentHandlePrefix prefix)] + <> [ReferencePrefixNotDeclared scope path prefix | prefix `notElem` declaredPrefixes] + <> [ReferenceRequiresIdField scope path | isNothing (rawSpec ^. #idField)] + <> [InvalidExternalReferenceScheme scope path scheme | scheme <- schemes, not (validUriScheme scheme)] + <> [ReferenceWithFormat scope path fieldFormat | Just fieldFormat <- [rule ^. #format]] + + fieldPathErrors scope rule = + pathPolicyErrors + scope + (topLevelFieldPath (rule ^. #field)) + (rule ^. #format) + (rule ^. #reference) + (rule ^. #path) + + -- The three ways a path policy can be incoherent on its own. Two reuse + -- the handle-reference constructors because the claim is identical: a + -- scheme that is not a legal URI scheme, and a structural interpretation + -- of a value paired with a textual format that would be checked against + -- the same text. The third is genuinely new — a value cannot be resolved + -- as both a @PREFIX-N@ handle and a §6.2 path — and cannot arise at + -- nested scope, where 'NestedFieldRule' carries no handle policy. + pathPolicyErrors scope path declaredFormat handlePolicy = \case + Nothing -> [] + Just policy -> + [ InvalidExternalReferenceScheme scope path scheme + | scheme <- deduplicateSchemes (policy ^. #externalUriSchemes), + not (validUriScheme scheme) + ] + <> [ReferenceWithFormat scope path fieldFormat | Just fieldFormat <- [declaredFormat]] + <> [PathReferenceWithHandleReference scope path | isJust handlePolicy] + + mergedReferenceErrors typeRule = + [ ConflictingReferencePrefix (typeRule ^. #type_) (topLevelFieldPath key) (profilePolicy ^. #localPrefix) (typePolicy ^. #localPrefix) + | let typeFields = compileRules (typeRule ^. #frontmatter), + (key, (profileRule, typeFieldRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeFields), + Just profilePolicy <- [profileRule ^. #reference], + Just typePolicy <- [typeFieldRule ^. #reference], + profilePolicy ^. #localPrefix /= typePolicy ^. #localPrefix + ] + <> [ ReferenceWithFormat (Just (typeRule ^. #type_)) (topLevelFieldPath key) fieldFormat + | let typeFields = compileRules (typeRule ^. #frontmatter), + (key, (profileRule, typeFieldRule)) <- Map.toAscList (Map.intersectionWith (,) baseRules typeFields), + (referenceRule, formatRule) <- [(profileRule, typeFieldRule), (typeFieldRule, profileRule)], + isJust (referenceRule ^. #reference), + Just fieldFormat <- [formatRule ^. #format] + ] + + -- Only a value okf cannot parse is rejected. An unknown /major/ is + -- deliberately accepted, unlike in @okfVersion@: there the profile is asking + -- okf to interpret rules it may not understand, while here it is stating a + -- minimum that a bundle's own declaration is compared against, which stays + -- meaningful whatever the major is. + requiredBundleVersionErrors = + case rawSpec ^. #requireBundleVersion of + Just rawVersion + | isNothing (parseOkfVersion rawVersion) -> [InvalidRequiredBundleVersion rawVersion] + _ -> [] + + versionErrors = + case effectiveProfileVersion (rawSpec ^. #okfVersion) of + Left versionError -> [versionError] + Right effectiveVersion -> + let atLeastV02 = effectiveVersion >= okfVersion02 + v02Text = renderOkfVersion okfVersion02 + -- The /effective/ version, not the raw declared string: a profile + -- declaring 0.9 is checked as 0.2 and its diagnostics should say so + -- rather than repeating a number okf did not act on. + declaredText = renderOkfVersion effectiveVersion + in -- A key v0.2 superseded, demanded by a profile declaring v0.2 or + -- later. Deliberately /not/ checked in the optional list: a team + -- migrating a corpus wants @generated@ required and @timestamp@ + -- tolerated but not demanded, and the optional list says exactly + -- that. This is the one check whose answer depends on which presence + -- list a rule came from, so it reads the raw lists rather than the + -- compiled map, which erases the distinction into presence clauses. + [ FieldSupersededInOkfVersion scope (topLevelFieldPath (rule ^. #field)) declaredText v02Text + | atLeastV02, + (scope, rules) <- scopedFrontmatterRules, + rule <- rules ^. #required <> rules ^. #recommended, + rule ^. #field `elem` fieldsSupersededInV02 + ] + -- The actor formats encode the specification §7 convention that + -- v0.2 introduced. A format is an okf descriptor feature rather + -- than a key name, so unlike the mirror case below it has no + -- house-convention reading: @FieldFormat.Actor@ /is/ §7. + <> [ FormatRequiresOkfVersion scope path fieldFormat declaredText v02Text + | not atLeastV02, + (scope, path, fieldFormat) <- scopedFormats, + fieldFormat `elem` [Actor, HumanActor] + ] + + -- There is deliberately no mirror check, "a profile declaring v0.1 names a + -- key v0.2 introduced", which is why 'fieldsIntroducedInV02' is unused here. + -- A profile key /name/ does not imply the OKF core key of that name: per + -- docs/adr/1-profile-declared-document-ids.md, constraining keys the core + -- format does not own is what profiles are for, and @status@, @sources@, and + -- @verified@ are ordinary words teams were already using as house conventions + -- before v0.2 claimed them. Such a check is both retroactive and ambiguous, + -- which docs/adr/11-growing-the-profile-descriptor-language.md forbids. + + -- Every declared format paired with the path it sits at, top-level first and + -- then nested. Only the format checks descend: 'fieldsIntroducedInV02' and + -- 'fieldsSupersededInV02' name /concept-level/ frontmatter keys, so matching + -- them against a member of a record would reject a profile whose element + -- happens to be called @status@ for having a v0.2 key it does not have. + scopedFormats = + [ (scope, topLevelFieldPath (rule ^. #field), fieldFormat) + | (scope, rules) <- scopedFrontmatterRules, + rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + Just fieldFormat <- [rule ^. #format] + ] + <> List.nub + [ (scope, nestedDefinitionPath (rule ^. #field) (nestedRule ^. #field), fieldFormat) + | (scope, rules) <- scopedFrontmatterRules, + rule <- rules ^. #required <> rules ^. #recommended <> rules ^. #optional, + nestedRules <- declaredNestedRuleSets rule, + nestedRule <- nestedRules ^. #required <> nestedRules ^. #recommended <> nestedRules ^. #optional, + Just fieldFormat <- [nestedRule ^. #format] + ] + + renderFieldPathKey (FieldPath (firstSegment :| remainingSegments)) = + Text.intercalate "." (map renderSegment (firstSegment : remainingSegments)) + renderSegment (FieldName name) = name + renderSegment (ArrayIndex elementIndex) = Text.pack (show elementIndex) + +-- | The OKF version that introduced the v0.2 frontmatter families and the actor +-- convention. Written out rather than reusing 'supportedOkfVersion', which +-- happens to equal it today: one is "what okf implements" and the other is "what +-- introduced these keys", and they will diverge at the next minor bump. +okfVersion02 :: OkfVersion +okfVersion02 = OkfVersion {okfVersionMajor = 0, okfVersionMinor = 2} + +-- | The OKF version a profile's rules are checked against, or why okf cannot +-- tell. +-- +-- A higher /minor/ within a known major is clamped, mirroring +-- 'Okf.Validation.versionGate': specification §12 defines a minor bump as +-- backward-compatible additions, so every rule a v0.3 profile can express is one +-- okf already understands. +-- +-- An unknown /major/ is deliberately an error, where the bundle side reads +-- best-effort — this is a considered divergence, not an oversight. §12's +-- best-effort instruction is about bundles, which may come from a third party +-- okf cannot ask. A profile is not a document okf is asked to read; it is an +-- instruction to okf about what to check, written by an author who is present. +-- Silently ignoring an instruction okf cannot interpret is worse than saying so. +-- See @docs\/adr\/10-okf-version-declaration-and-best-effort-reading.md@. +effectiveProfileVersion :: Text -> Either ProfileDefinitionError OkfVersion +effectiveProfileVersion rawVersion = + case parseOkfVersion rawVersion of + Nothing -> Left (InvalidProfileOkfVersion rawVersion) + Just declared + | okfVersionMajor declared == okfVersionMajor supportedOkfVersion -> + Right (min declared supportedOkfVersion) + | otherwise -> Left (ProfileOkfVersionNotUnderstood rawVersion) + +compileRules :: FrontmatterRules -> Map Text EffectiveFieldRule +compileRules FrontmatterRules {required, recommended, optional} = + Map.fromList + ( [ (rule ^. #field, compileFieldRule RequiredField rule) + | rule <- required + ] + <> [ (rule ^. #field, compileFieldRule RecommendedField rule) + | rule <- recommended + ] + <> [ (rule ^. #field, compileOptionalFieldRule rule) + | rule <- optional + ] + ) + +-- | Compile a rule the profile documents but never demands. It carries no +-- presence clause, so 'applicablePresenceClause' can never find one to report in +-- either validation mode, while every value check still runs from the +-- present-value branch. This is also the value constraints a required or +-- recommended rule is built from. +compileOptionalFieldRule :: FieldRule -> EffectiveFieldRule +compileOptionalFieldRule rule = + EffectiveFieldRule + { presenceClauses = [], + description = rule ^. #description, + allowedValues = deduplicate (rule ^. #allowedValues), + cardinality = + -- Declaring a nested shape and no explicit cardinality refines what the + -- value may be, because the shape only makes sense against one. A rule + -- declaring both shapes stays 'Any', which is what lets either spelling + -- of the OKF v0.2 @verified@ key satisfy it. + case (rule ^. #objectFields, rule ^. #elementFields, rule ^. #cardinality) of + (Just _, Just _, Any) -> Any + (Just _, Nothing, Any) -> Object + (Nothing, Just _, Any) -> List + (_, _, Any) -> refineCardinalityForFormat (rule ^. #format) + (_, _, declared) -> declared, + format = rule ^. #format, + elementFields = compileNestedRules <$> rule ^. #elementFields, + objectFields = compileNestedRules <$> rule ^. #objectFields, + reference = compileReferenceRule <$> rule ^. #reference, + path = compilePathRule <$> rule ^. #path + } + +-- | The cardinality a rule with no declared one takes from its format. +-- +-- A non-textual format implies a scalar, and without this the rule would be +-- useless: the 'Any' cardinality routes presence through 'legacyValueIsPresent', +-- which counts only non-empty text and non-empty arrays, so a @usage_count: +-- 5000@ is reported /missing/ before its value is ever examined. Refining here +-- rather than widening 'legacyValueIsPresent' keeps the meaning of every +-- descriptor that already exists — in particular a key whose value is @false@ +-- keeps being reported as missing when no rule says otherwise. +-- +-- An explicitly declared cardinality always wins, including @list@: a list of +-- integers is a coherent thing to demand, so pairing a numeric format with +-- 'List' is left alone rather than made an error. +refineCardinalityForFormat :: Maybe FieldFormat -> Cardinality +refineCardinalityForFormat = \case + Just Integer -> Scalar + Just NonNegativeInteger -> Scalar + Just Boolean -> Scalar + _ -> Any + +compileFieldRule :: FieldRequirement -> FieldRule -> EffectiveFieldRule +compileFieldRule requirement rule = + (compileOptionalFieldRule rule) + { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)] + } + +compileNestedRules :: NestedRules -> Map Text EffectiveFieldRule +compileNestedRules NestedRules {required, recommended, optional} = + Map.fromList + ( [ (rule ^. #field, compileNestedFieldRule RequiredField rule) + | rule <- required + ] + <> [ (rule ^. #field, compileNestedFieldRule RecommendedField rule) + | rule <- recommended + ] + <> [ (rule ^. #field, compileOptionalNestedFieldRule rule) + | rule <- optional + ] + ) + +-- | The nested counterpart of 'compileOptionalFieldRule'. +compileOptionalNestedFieldRule :: NestedFieldRule -> EffectiveFieldRule +compileOptionalNestedFieldRule rule = + EffectiveFieldRule + { presenceClauses = [], + description = rule ^. #description, + allowedValues = deduplicate (rule ^. #allowedValues), + cardinality = + case rule ^. #cardinality of + Any -> refineCardinalityForFormat (rule ^. #format) + declared -> declared, + format = rule ^. #format, + elementFields = Nothing, + -- Nested rules stay depth-bounded: 'NestedFieldRule' has no object member, + -- so a profile cannot constrain @sources[0].usage_window.from@. + objectFields = Nothing, + -- Still 'Nothing': 'NestedFieldRule' carries no document-handle policy. + reference = Nothing, + -- But it does carry a path policy, which is the point of the member — + -- @sources[].resource@ is only reachable here. + path = compilePathRule <$> rule ^. #path + } + +compileNestedFieldRule :: FieldRequirement -> NestedFieldRule -> EffectiveFieldRule +compileNestedFieldRule requirement rule = + (compileOptionalNestedFieldRule rule) + { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)] + } + +mergeRules :: Map Text EffectiveFieldRule -> Map Text EffectiveFieldRule -> Map Text EffectiveFieldRule +mergeRules = Map.unionWith mergeEffectiveFieldRule + +mergeEffectiveFieldRule :: EffectiveFieldRule -> EffectiveFieldRule -> EffectiveFieldRule +mergeEffectiveFieldRule profileRule typeRule = + EffectiveFieldRule + { presenceClauses = profileRule ^. #presenceClauses <> typeRule ^. #presenceClauses, + description = typeRule ^. #description <|> profileRule ^. #description, + allowedValues = mergeVocabulary (profileRule ^. #allowedValues) (typeRule ^. #allowedValues), + cardinality = mergeCardinality (profileRule ^. #cardinality) (typeRule ^. #cardinality), + format = fromMaybe (profileRule ^. #format) (mergeFieldFormat (profileRule ^. #format) (typeRule ^. #format)), + elementFields = mergeNestedRuleMaps (profileRule ^. #elementFields) (typeRule ^. #elementFields), + objectFields = mergeNestedRuleMaps (profileRule ^. #objectFields) (typeRule ^. #objectFields), + reference = fromMaybe (profileRule ^. #reference) (mergeReferenceRule (profileRule ^. #reference) (typeRule ^. #reference)), + path = mergePathRule (profileRule ^. #path) (typeRule ^. #path) + } + +-- | Normalize a declared condition for storage in a 'PresenceClause': the shape +-- is unchanged, but the accepted-value list is deduplicated so that a clause +-- reported in a 'ProfileViolation' does not repeat a value the author wrote +-- twice. +compileCondition :: FieldCondition -> FieldCondition +compileCondition rawCondition = + FieldCondition + { field = rawCondition ^. #field, + hasValue = deduplicate (rawCondition ^. #hasValue) + } + +compileReferenceRule :: HandleReferenceRule -> HandleReferenceRule +compileReferenceRule policy = + HandleReferenceRule + { localPrefix = policy ^. #localPrefix, + externalUriSchemes = map Text.toCaseFold (deduplicateSchemes (policy ^. #externalUriSchemes)), + allowSelf = policy ^. #allowSelf + } + +compilePathRule :: PathReferenceRule -> PathReferenceRule +compilePathRule policy = + PathReferenceRule + { externalUriSchemes = map Text.toCaseFold (deduplicateSchemes (policy ^. #externalUriSchemes)), + allowSelf = policy ^. #allowSelf + } + +-- | Combine a profile-scope path policy with a type-scope one: intersect the +-- permitted schemes and require both scopes to allow self-reference. +-- +-- Unlike 'mergeReferenceRule' this is total and needs no @Maybe@-of-@Maybe@ +-- result, because a path policy has no @localPrefix@ — the one thing two +-- handle policies can flatly disagree about. Narrowing to the intersection is +-- the same direction 'mergeVocabulary' takes: a type rule tightens the +-- profile-wide rule and never loosens it. +mergePathRule :: Maybe PathReferenceRule -> Maybe PathReferenceRule -> Maybe PathReferenceRule +mergePathRule Nothing typePolicy = typePolicy +mergePathRule profilePolicy Nothing = profilePolicy +mergePathRule (Just profilePolicy) (Just typePolicy) = + Just + PathReferenceRule + { externalUriSchemes = + filter + (`Set.member` Set.fromList (typePolicy ^. #externalUriSchemes)) + (profilePolicy ^. #externalUriSchemes), + allowSelf = profilePolicy ^. #allowSelf && typePolicy ^. #allowSelf + } + +-- | Merge one scope's map of member rules with another's. Used for both +-- @elementFields@ and @objectFields@; it was named for the former until the +-- latter existed and is a plain union-with-merge either way. +mergeNestedRuleMaps :: Maybe (Map Text EffectiveFieldRule) -> Maybe (Map Text EffectiveFieldRule) -> Maybe (Map Text EffectiveFieldRule) +mergeNestedRuleMaps Nothing typeRules = typeRules +mergeNestedRuleMaps profileRules Nothing = profileRules +mergeNestedRuleMaps (Just profileRules) (Just typeRules) = Just (Map.unionWith mergeEffectiveFieldRule profileRules typeRules) + +mergeReferenceRule :: Maybe HandleReferenceRule -> Maybe HandleReferenceRule -> Maybe (Maybe HandleReferenceRule) +mergeReferenceRule Nothing typePolicy = Just typePolicy +mergeReferenceRule profilePolicy Nothing = Just profilePolicy +mergeReferenceRule (Just profilePolicy) (Just typePolicy) + | profilePolicy ^. #localPrefix == typePolicy ^. #localPrefix = + Just . Just $ + HandleReferenceRule + { localPrefix = profilePolicy ^. #localPrefix, + externalUriSchemes = + filter + (`Set.member` Set.fromList (typePolicy ^. #externalUriSchemes)) + (profilePolicy ^. #externalUriSchemes), + allowSelf = profilePolicy ^. #allowSelf && typePolicy ^. #allowSelf + } + | otherwise = Nothing + +mergeFieldFormat :: Maybe FieldFormat -> Maybe FieldFormat -> Maybe (Maybe FieldFormat) +mergeFieldFormat Nothing typeFormat = Just typeFormat +mergeFieldFormat profileFormat Nothing = Just profileFormat +mergeFieldFormat (Just Uri) (Just typeFormat@(UriWithScheme _)) = Just (Just typeFormat) +mergeFieldFormat (Just profileFormat@(UriWithScheme _)) (Just Uri) = Just (Just profileFormat) +mergeFieldFormat (Just Actor) (Just HumanActor) = Just (Just HumanActor) +mergeFieldFormat (Just HumanActor) (Just Actor) = Just (Just HumanActor) +mergeFieldFormat (Just Integer) (Just NonNegativeInteger) = Just (Just NonNegativeInteger) +mergeFieldFormat (Just NonNegativeInteger) (Just Integer) = Just (Just NonNegativeInteger) +mergeFieldFormat profileFormat typeFormat + | profileFormat == typeFormat = Just profileFormat + | otherwise = Nothing + +invalidFormatParameter :: FieldFormat -> Maybe (FieldFormat, Text) +invalidFormatParameter fieldFormat = + case fieldFormat of + UriWithScheme scheme + | not (validUriScheme scheme) -> Just (fieldFormat, scheme) + DocumentHandle prefix + | not (validDocumentHandlePrefix prefix) -> Just (fieldFormat, prefix) + _ -> Nothing + +validUriScheme :: Text -> Bool +validUriScheme scheme = + case Text.uncons scheme of + Just (firstCharacter, rest) -> isAsciiLetter firstCharacter && Text.all validRest rest + Nothing -> False + where + validRest character = + isAsciiLetter character + || ('0' <= character && character <= '9') + || character `elem` ['+', '.', '-'] + +validDocumentHandlePrefix :: Text -> Bool +validDocumentHandlePrefix prefix = + case parseDocumentId (prefix <> "-1") of + Just documentId -> documentId ^. #prefix == prefix + Nothing -> False + +isAsciiLetter :: Char -> Bool +isAsciiLetter character = isAsciiLower character || isAsciiUpper character + +mergeCardinality :: Cardinality -> Cardinality -> Cardinality +mergeCardinality Any typeCardinality = typeCardinality +mergeCardinality profileCardinality Any = profileCardinality +mergeCardinality profileCardinality _typeCardinality = profileCardinality + +mergeVocabulary :: [Text] -> [Text] -> [Text] +mergeVocabulary [] typeValues = typeValues +mergeVocabulary profileValues [] = profileValues +mergeVocabulary profileValues typeValues = + filter (`Set.member` Set.fromList typeValues) profileValues + +deduplicate :: [Text] -> [Text] +deduplicate = go Set.empty + where + go _ [] = [] + go seen (value : rest) + | value `Set.member` seen = go seen rest + | otherwise = value : go (Set.insert value seen) rest + +deduplicateSchemes :: [Text] -> [Text] +deduplicateSchemes = go Set.empty + where + go _ [] = [] + go seen (scheme : rest) + | normalized `Set.member` seen = go seen rest + | otherwise = scheme : go (Set.insert normalized seen) rest + where + normalized = Text.toCaseFold scheme + +effectiveRulesForType :: CompiledProfile -> Text -> Map Text EffectiveFieldRule +effectiveRulesForType compiled ctype = + Map.findWithDefault (compiled ^. #baseRules) ctype (compiled ^. #rulesByType) + +profileFieldDescriptionForType :: CompiledProfile -> Text -> Text -> Maybe Text +profileFieldDescriptionForType compiled ctype key = + Map.lookup key (effectiveRulesForType compiled ctype) >>= (^. #description) + +-- | A parsed document handle: an ASCII-letter-led alphanumeric prefix and a +-- positive number, rendered as @PREFIX-N@. +data DocumentId = DocumentId + { prefix :: !Text, + number :: !Natural + } + deriving stock (Generic, Eq, Ord, Show) + +-- | Parse a strict document handle. The prefix contains one or more ASCII +-- letters or digits and begins with a letter. It is followed by exactly one +-- hyphen and a positive decimal number with no leading zero. Thus @ADR-7@ +-- parses, while @ADR-007@, @ADR-0@, @ADR-@, @-7@, @adr 7@, and +-- @ADR-7-extra@ do not. +parseDocumentId :: Text -> Maybe DocumentId +parseDocumentId raw = + case Text.splitOn "-" raw of + [prefixText, numberText] + | validPrefix prefixText, + validNumberText numberText -> + case Text.Read.decimal numberText of + Right (parsedNumber, remainder) + | Text.null remainder, + parsedNumber > 0 -> + Just (DocumentId prefixText parsedNumber) + _ -> Nothing + _ -> Nothing + where + validPrefix value = + case Text.uncons value of + Just (firstCharacter, rest) -> + isAsciiLetter firstCharacter && Text.all isAsciiAlphaNumeric rest + Nothing -> False + validNumberText value = + case Text.uncons value of + Just (firstCharacter, rest) -> + firstCharacter >= '1' + && firstCharacter <= '9' + && Text.all isAsciiDigit rest + Nothing -> False + isAsciiDigit character = + character >= '0' && character <= '9' + isAsciiAlphaNumeric character = + isAsciiLetter character || isAsciiDigit character + +-- | Render a document handle as @PREFIX-N@. +renderDocumentId :: DocumentId -> Text +renderDocumentId DocumentId {prefix, number} = + prefix <> "-" <> Text.pack (show number) + +-- | Every well-formed handle under the profile's ID field, paired with the +-- concept carrying it and sorted by prefix, number, then concept ID. Concepts +-- without a well-formed handle are omitted. A profile with no ID field yields +-- an empty list. +documentIdsInBundle :: ProfileSpec -> [Concept] -> [(DocumentId, ConceptId)] +documentIdsInBundle spec concepts = + case spec ^. #idField of + Nothing -> [] + Just fieldName -> + List.sortOn + (\(documentId, cid) -> (documentId, renderConceptId cid)) + [ (documentId, conceptIdOf concept) + | concept <- concepts, + Just (String rawDocumentId) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], + Just documentId <- [parseDocumentId rawDocumentId] + ] + +-- | Allocate one more than the highest document-ID number already used for the +-- given prefix, or number 1 when the prefix is unused. Gaps are deliberately +-- not filled: reusing a retired number could make an old reference silently +-- point at a different document. +nextDocumentId :: ProfileSpec -> [Concept] -> Text -> DocumentId +nextDocumentId spec concepts requestedPrefix = + DocumentId + { prefix = requestedPrefix, + number = highestNumber + 1 + } + where + highestNumber = + List.foldl' + max + 0 + [ documentId ^. #number + | (documentId, _) <- documentIdsInBundle spec concepts, + documentId ^. #prefix == requestedPrefix + ] + +-- | One structural segment of a frontmatter path. EP-2 produces top-level +-- 'FieldName' paths; later bounded nested validation can append field names and +-- array indexes without encoding paths as ad hoc text. +data FieldPathSegment + = FieldName Text + | ArrayIndex Int + deriving stock (Generic, Eq, Ord, Show) + +newtype FieldPath = FieldPath + { segments :: NonEmpty FieldPathSegment + } + deriving stock (Generic, Eq, Ord, Show) + +topLevelFieldPath :: Text -> FieldPath +topLevelFieldPath key = FieldPath (FieldName key :| []) + +nestedDefinitionPath :: Text -> Text -> FieldPath +nestedDefinitionPath parent child = + FieldPath (FieldName parent :| [FieldName child]) + +nestedValuePath :: Text -> Int -> Text -> FieldPath +nestedValuePath parent elementIndex child = + FieldPath (FieldName parent :| [ArrayIndex elementIndex, FieldName child]) + +nestedElementPath :: Text -> Int -> FieldPath +nestedElementPath parent elementIndex = + FieldPath (FieldName parent :| [ArrayIndex elementIndex]) + +-- | A single deviation from a profile. Advisory by default at the CLI layer. +data ProfileViolation + = -- | concept's @type@ is not listed in the profile and unknown types are disallowed + TypeNotInProfile ConceptId Text + | -- | a required frontmatter key is missing or empty (concept, key, activating condition) + MissingProfileField ConceptId Text (Maybe FieldCondition) + | -- | a recommended frontmatter key is missing under strict authoring + MissingRecommendedProfileField ConceptId Text (Maybe FieldCondition) + | -- | a required field is missing inside one list element record + MissingNestedProfileField ConceptId FieldPath (Maybe FieldCondition) + | -- | a recommended nested field is missing under strict authoring + MissingRecommendedNestedProfileField ConceptId FieldPath (Maybe FieldCondition) + | -- | a present value is outside the effective textual vocabulary + ValueNotInVocabulary ConceptId FieldPath [Text] Value + | -- | a present value has the wrong scalar/list shape + CardinalityMismatch ConceptId FieldPath Cardinality Value + | -- | a present value does not satisfy its named textual format + ValueFormatMismatch ConceptId FieldPath FieldFormat Value + | -- | a local reference has the right prefix but no valid owner in this bundle + DanglingHandleReference ConceptId FieldPath Text + | -- | a parsed local handle uses a prefix other than the declared target prefix + ReferenceHandlePrefixMismatch ConceptId FieldPath Text Text + | -- | a reference value is neither textual local handle nor valid absolute URI + MalformedDocumentReference ConceptId FieldPath Value + | -- | an absolute external URI uses a scheme the profile did not permit + ExternalReferenceSchemeNotAllowed ConceptId FieldPath Text [Text] + | -- | a local handle, or a bundle path, resolves to the concept carrying it + SelfDocumentReference ConceptId FieldPath Text + | -- | a path-valued field's value is not one of the three shapes of §6.2 + MalformedPathReference ConceptId FieldPath Value + | -- | a relative path climbs above the bundle root + PathEscapesBundle ConceptId FieldPath Text + | -- | a bundle path names a concept that does not exist in this bundle + DanglingPathReference ConceptId FieldPath Text + | -- | a closed profile does not declare this top-level field + FieldNotInProfile ConceptId Text + | -- | a declared list element is not an object record + NestedElementNotRecord ConceptId FieldPath Value + | -- | concept's file path does not match the type rule's pattern (concept, type, pattern) + PathPatternMismatch ConceptId Text Text + | -- | type rule requires a resource scheme but resource is absent (concept, type, scheme) + MissingResource ConceptId Text Text + | -- | resource present but its scheme is wrong (concept, expected scheme, actual resource) + ResourceSchemeMismatch ConceptId Text Text + | -- | required @# Schema@ section is absent (concept, type) + MissingSchemaSection ConceptId Text + | -- | @# Schema@ table columns do not match (concept, type, expected, actual) + SchemaColumnsMismatch ConceptId Text [Text] [Text] + | -- | type rule declares an @idPrefix@ but the concept has no handle (concept, type, prefix) + MissingDocumentId ConceptId Text Text + | -- | handle present but malformed for the declared prefix (concept, prefix, actual value) + MalformedDocumentId ConceptId Text Text + | -- | the same handle appears on more than one concept (handle, concept, other concept) + DuplicateDocumentId Text ConceptId ConceptId + | -- | the profile requires the bundle to declare an OKF version it does not + -- (required version, what the bundle declared, 'Nothing' when undeclared) + -- + -- The only violation that belongs to the bundle rather than to a concept, so + -- a consumer grouping violations by 'ConceptId' has nothing to key it on. + RequiredBundleVersionUnmet Text (Maybe Text) + deriving stock (Generic, Eq, Show) + +-- | Check every concept against a compiled profile, returning all deviations. +-- Profile-wide rules apply even to unknown types; a matching type rule adds its +-- frontmatter rules and the existing type-specific structural checks. +-- +-- Existence is decided against the concepts themselves, so a @path@ rule can +-- tell whether a target names a concept and cannot tell whether it names +-- @references\/attesters\/revenue.py@; such a target is accepted unchecked. +-- Callers holding a real directory should use 'validateProfileWith'. +validateProfile :: ValidationProfile -> CompiledProfile -> [Concept] -> [ProfileViolation] +validateProfile = + validateProfileWithPresence conceptsOnly bundleInventoryOfConcepts + where + -- Narrowed to @.md@ on purpose. A caller with concepts and no directory can + -- decide a @.md@ target, because a 'Concept' /is/ a non-reserved @.md@ + -- file — but it has never been able to see §6.3's + -- @references/attesters/revenue.py@, and answering 'TargetAbsent' for it + -- would turn a question okf cannot ask into a rejection. + conceptsOnly conceptInventory resolved + | FilePath.takeExtension resolved /= ".md" = TargetUnknown + | bundleInventoryMember resolved conceptInventory = TargetPresent + | otherwise = TargetAbsent + +-- | 'validateProfile' with the bundle's full file inventory, so a @path@ rule +-- can decide whether a target that is not a concept exists. +-- +-- Specification §6.3's own example of a path target is +-- @references\/attesters\/revenue.py@, which is not a concept and which +-- 'validateProfile' therefore accepts unchecked. A caller that walked a real +-- directory has 'Okf.Bundle.walkBundleInventory' and can do better. See +-- @docs\/adr\/13-the-references-convention-and-non-markdown-files.md@. +-- +-- Passing an inventory does not make validation touch the filesystem. The +-- inventory is data read once during the bundle walk, where okf is already doing +-- IO, which is the shape @docs\/adr\/5-compile-profile-rules-before-validation.md@ +-- requires and the one the core §6.2 check already uses. +validateProfileWith :: BundleInventory -> ValidationProfile -> CompiledProfile -> [Concept] -> [ProfileViolation] +validateProfileWith inventory = + validateProfileWithPresence everyFile (const inventory) + where + everyFile fullInventory resolved + | bundleInventoryMember resolved fullInventory = TargetPresent + | otherwise = TargetAbsent + +-- | Check a bundle's specification §12 version declaration against the profile's +-- @requireBundleVersion@ setting. Returns @[]@ when the profile requires nothing, +-- which is the default and the case for almost every profile. +-- +-- Deliberately a separate entry point rather than a parameter on +-- 'validateProfile' and 'validateProfileWith'. Those two are public and their +-- signatures are depended on downstream, and this check consults no concepts at +-- all: threading a bundle-scoped question through a concept-walking function +-- would be misleading as well as breaking. +-- +-- §12 makes the declaration a MAY, so okf's own validator never asks for one — +-- see @docs\/adr\/10-okf-version-declaration-and-best-effort-reading.md@. This is +-- the house-convention half: nothing is reported unless a profile author wrote +-- the field. +-- +-- A declaration okf cannot parse counts as unmet. It cannot be compared, okf +-- already reports it separately as a strict-mode authoring lint, and silently +-- passing it would let a typo satisfy a requirement. +validateProfileVersion :: VersionDeclaration -> CompiledProfile -> [ProfileViolation] +validateProfileVersion declaration compiled = + case compiledProfileRequiredBundleVersion compiled of + Nothing -> [] + Just required -> + let unmet = [RequiredBundleVersionUnmet (renderOkfVersion required) declaredText] + in case declaration of + -- A bundle ahead of the house minimum is not a deviation: §12 defines + -- a minor bump as backward-compatible additions. + VersionDeclared declared | declared >= required -> [] + VersionDeclared _ -> unmet + VersionUnparseable _ -> unmet + VersionUndeclared -> unmet + where + declaredText = case declaration of + VersionDeclared declared -> Just (renderOkfVersion declared) + VersionUnparseable rawVersion -> Just rawVersion + VersionUndeclared -> Nothing + +-- | The shared body of 'validateProfile' and 'validateProfileWith'. +-- +-- The first argument decides what a @path@ rule may conclude about a resolved +-- §6.2 target; the second supplies the inventory it consults, derived from the +-- concepts when the caller has no directory to walk. Keeping one implementation +-- is what stops the two entry points from drifting apart on everything /except/ +-- the one question that distinguishes them. +validateProfileWithPresence :: + (BundleInventory -> FilePath -> PathTargetPresence) -> + ([Concept] -> BundleInventory) -> + ValidationProfile -> + CompiledProfile -> + [Concept] -> + [ProfileViolation] +validateProfileWithPresence presenceRule inventoryOf validationProfile compiled concepts = + concatMap checkConcept sortedConcepts <> checkDuplicateDocumentIds spec sortedConcepts + where + spec = compiledProfileSpec compiled + sortedConcepts = List.sortOn (renderConceptId . conceptIdOf) concepts + rulesByType = [(rule ^. #type_, rule) | rule <- spec ^. #types] + validDocumentIdIndex = buildValidDocumentIdIndex spec rulesByType sortedConcepts + -- What this caller can say about a resolved §6.2 path, built once. + presenceOf = presenceRule (inventoryOf sortedConcepts) + + checkConcept concept = + let cid = conceptIdOf concept + ctype = conceptType concept + fieldViolations = checkFields cid ctype concept <> checkUnknownFields cid ctype concept + in case lookup ctype rulesByType of + Nothing -> + [TypeNotInProfile cid ctype | not (spec ^. #allowUnknownTypes)] <> fieldViolations + Just rule -> + fieldViolations + <> checkPath cid ctype rule + <> checkResource cid ctype rule concept + <> checkSchema cid ctype rule concept + <> checkDocumentId spec cid ctype rule concept + + checkFields cid ctype concept = + concatMap checkField (Map.toAscList (effectiveRulesForType compiled ctype)) + where + checkField (key, rule) = + case evaluateFieldValue rule (frontmatterLookup key (conceptFrontmatter concept)) of + FieldAbsent actual -> + presenceViolations key rule + <> maybe [] (vocabularyViolations key rule) actual + <> maybe [] (formatViolations key rule) actual + <> maybe [] (referenceViolations key rule) actual + <> maybe [] (pathViolations (topLevelFieldPath key) rule) actual + FieldPresent actual -> + vocabularyViolations key rule actual + <> formatViolations key rule actual + <> referenceViolations key rule actual + <> pathViolations (topLevelFieldPath key) rule actual + <> nestedViolations key rule actual + <> objectViolations key rule actual + FieldWrongShape actual -> [CardinalityMismatch cid (topLevelFieldPath key) (rule ^. #cardinality) actual] + + presenceViolations key rule = + case applicablePresenceClause validationProfile (\sourceKey -> frontmatterLookup sourceKey (conceptFrontmatter concept)) rule of + Nothing -> [] + Just clause -> + [ case clause ^. #requirement of + RequiredField -> MissingProfileField cid key (clause ^. #condition) + RecommendedField -> MissingRecommendedProfileField cid key (clause ^. #condition) + ] + vocabularyViolations key rule actual = + [ ValueNotInVocabulary cid (topLevelFieldPath key) (rule ^. #allowedValues) actual + | not (null (rule ^. #allowedValues)), + not (valueMatchesVocabulary (rule ^. #allowedValues) actual) + ] + formatViolations key rule actual = + [ ValueFormatMismatch cid (topLevelFieldPath key) fieldFormat actual + | Just fieldFormat <- [rule ^. #format], + not (valueMatchesFormat fieldFormat actual) + ] + referenceViolations key rule actual = + case rule ^. #reference of + Nothing -> [] + Just policy -> validateReferenceValue validDocumentIdIndex cid (topLevelFieldPath key) policy actual + + -- Takes a 'FieldPath' rather than a key because it is shared by all + -- three scopes: a top-level key, a member of a list element, and a + -- member of an object-valued mapping. + pathViolations fieldPath rule actual = + case rule ^. #path of + Nothing -> [] + Just policy -> validatePathValue presenceOf cid fieldPath policy actual + + nestedViolations parentKey parentRule = \case + Array elementValues + | Just nestedRules <- parentRule ^. #elementFields -> + concat + [ case elementValue of + Aeson.Object members -> + concatMap + (checkRecordMember (nestedValuePath parentKey elementIndex) members) + (Map.toAscList nestedRules) + _ -> [NestedElementNotRecord cid (nestedElementPath parentKey elementIndex) elementValue] + | (elementIndex, elementValue) <- zip [0 ..] (Vector.toList elementValues) + ] + _ -> [] + + -- The mapping spelling of the same idea. The value /is/ the record, so + -- there is no index in the path: a member is reported as + -- @generated.by@ rather than @generated[0].by@. + objectViolations parentKey parentRule = \case + Aeson.Object members + | Just objectRules <- parentRule ^. #objectFields -> + concatMap + (checkRecordMember (nestedDefinitionPath parentKey) members) + (Map.toAscList objectRules) + _ -> [] + + -- Check one member of one record. Shared by the list-element and + -- object-value walks, which differ only in how they name the member; + -- the sibling lookup that resolves a @when@ condition stays scoped to + -- the record the member lives in either way. + checkRecordMember buildPath members (key, rule) = + let path = buildPath key + actualValue = Aeson.KeyMap.lookup (Aeson.Key.fromText key) members + in case evaluateFieldValue rule actualValue of + FieldAbsent actual -> + nestedPresenceViolations members path rule + <> maybe [] (nestedVocabularyViolations path rule) actual + <> maybe [] (nestedFormatViolations path rule) actual + <> maybe [] (pathViolations path rule) actual + FieldPresent actual -> + nestedVocabularyViolations path rule actual + <> nestedFormatViolations path rule actual + <> pathViolations path rule actual + FieldWrongShape actual -> [CardinalityMismatch cid path (rule ^. #cardinality) actual] + + nestedPresenceViolations objectFields path rule = + case applicablePresenceClause validationProfile lookupSibling rule of + Nothing -> [] + Just clause -> + [ case clause ^. #requirement of + RequiredField -> MissingNestedProfileField cid path (clause ^. #condition) + RecommendedField -> MissingRecommendedNestedProfileField cid path (clause ^. #condition) + ] + where + lookupSibling sourceKey = Aeson.KeyMap.lookup (Aeson.Key.fromText sourceKey) objectFields + nestedVocabularyViolations path rule actual = + [ ValueNotInVocabulary cid path (rule ^. #allowedValues) actual + | not (null (rule ^. #allowedValues)), + not (valueMatchesVocabulary (rule ^. #allowedValues) actual) + ] + nestedFormatViolations path rule actual = + [ ValueFormatMismatch cid path fieldFormat actual + | Just fieldFormat <- [rule ^. #format], + not (valueMatchesFormat fieldFormat actual) + ] + + checkUnknownFields cid ctype concept + | spec ^. #allowUnknownFields = [] + | otherwise = + [ FieldNotInProfile cid key + | key <- frontmatterKeys (conceptFrontmatter concept), + key `Set.notMember` allowedFields ctype + ] + + allowedFields ctype = + coreFrontmatterFields + <> Map.keysSet (effectiveRulesForType compiled ctype) + <> maybe Set.empty Set.singleton (spec ^. #idField) + +-- | Index only handles that are valid owners under the compiled profile's raw +-- type declarations: the concept has a matching type rule, that rule declares +-- the parsed handle's exact prefix, and the profile declares the owning field. +-- Multiple owners are retained so a duplicate target still counts as existing; +-- the existing bundle-wide duplicate diagnostic remains authoritative. +buildValidDocumentIdIndex :: ProfileSpec -> [(Text, TypeRule)] -> [Concept] -> Map DocumentId [ConceptId] +buildValidDocumentIdIndex spec rulesByType concepts = + case spec ^. #idField of + Nothing -> Map.empty + Just fieldName -> + Map.fromListWith + (flip (<>)) + [ (documentId, [conceptIdOf concept]) + | concept <- concepts, + Just typeRule <- [lookup (conceptType concept) rulesByType], + Just expectedPrefix <- [typeRule ^. #idPrefix], + Just (String rawDocumentId) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], + Just documentId <- [parseDocumentId rawDocumentId], + documentId ^. #prefix == expectedPrefix + ] + +validateReferenceValue :: Map DocumentId [ConceptId] -> ConceptId -> FieldPath -> HandleReferenceRule -> Value -> [ProfileViolation] +validateReferenceValue validOwners sourceConcept path policy = \case + String rawReference -> validateReferenceText validOwners sourceConcept path policy rawReference + Array values -> + concat + [ case value of + String rawReference -> validateReferenceText validOwners sourceConcept (appendArrayIndex path elementIndex) policy rawReference + _ -> [MalformedDocumentReference sourceConcept (appendArrayIndex path elementIndex) value] + | (elementIndex, value) <- zip [0 ..] (Vector.toList values) + ] + actual -> [MalformedDocumentReference sourceConcept path actual] + +validateReferenceText :: Map DocumentId [ConceptId] -> ConceptId -> FieldPath -> HandleReferenceRule -> Text -> [ProfileViolation] +validateReferenceText validOwners sourceConcept path policy rawReference = + case parseDocumentId rawReference of + Just documentId + | documentId ^. #prefix /= policy ^. #localPrefix -> + [ReferenceHandlePrefixMismatch sourceConcept path rawReference (policy ^. #localPrefix)] + | otherwise -> + case Map.lookup documentId validOwners of + Nothing -> [DanglingHandleReference sourceConcept path rawReference] + Just owners + | not (policy ^. #allowSelf), + sourceConcept `elem` owners -> + [SelfDocumentReference sourceConcept path rawReference] + | otherwise -> [] + Nothing -> + case parseURI (Text.unpack rawReference) of + Just parsed + | not (Text.null normalizedScheme), normalizedScheme `elem` policy ^. #externalUriSchemes -> [] + | not (Text.null normalizedScheme) -> + [ ExternalReferenceSchemeNotAllowed + sourceConcept + path + normalizedScheme + (policy ^. #externalUriSchemes) + ] + | otherwise -> [MalformedDocumentReference sourceConcept path (String rawReference)] + where + normalizedScheme = Text.toCaseFold (Text.dropWhileEnd (== ':') (Text.pack (uriScheme parsed))) + Nothing -> [MalformedDocumentReference sourceConcept path (String rawReference)] + +-- | Check one path-valued frontmatter value, at any scope. A list is checked +-- element-wise so that a diagnostic names @sources[1].resource@ rather than the +-- whole list. +validatePathValue :: (FilePath -> PathTargetPresence) -> ConceptId -> FieldPath -> PathReferenceRule -> Value -> [ProfileViolation] +validatePathValue presenceOf sourceConcept path policy = \case + String rawPath -> validatePathText presenceOf sourceConcept path policy rawPath + Array values -> + concat + [ case value of + String rawPath -> + validatePathText presenceOf sourceConcept (appendArrayIndex path elementIndex) policy rawPath + _ -> [MalformedPathReference sourceConcept (appendArrayIndex path elementIndex) value] + | (elementIndex, value) <- zip [0 ..] (Vector.toList values) + ] + actual -> [MalformedPathReference sourceConcept path actual] + +-- | What a caller can say about a resolved §6.2 bundle path. +-- +-- Three answers rather than two, because "I cannot tell" is a real state and +-- collapsing it into "absent" turns silence into a rejection. 'validateProfile' +-- is handed concepts alone, so it genuinely cannot say whether §6.3's +-- @references\/attesters\/revenue.py@ is there, and reporting it as dangling +-- would be a claim okf did not check. +data PathTargetPresence + = -- | The bundle holds it. + TargetPresent + | -- | The bundle does not hold it, and the caller can see enough to be sure. + TargetAbsent + | -- | The caller cannot answer for this path. + TargetUnknown + deriving stock (Generic, Eq, Show) + +-- | Check one path value against the §6.2 grammar and the profile's policy. +-- +-- Every diagnostic carries the raw text the author wrote rather than the +-- collapsed path okf computed from it, so the message names something findable +-- in the file. +-- +-- Existence is decided by the supplied lookup, which reports what the caller can +-- actually see: 'validateProfileWith' holds a real directory's inventory and so +-- resolves §6.3's own @references\/attesters\/revenue.py@, while +-- 'validateProfile' holds the concepts alone and answers 'TargetUnknown' for it. +-- +-- The @.md@ branch still goes through 'conceptIdFromFilePath', because that is +-- what decides self-reference and what makes 'MalformedPathReference' reachable +-- for a path no concept ID could be built from. What it no longer decides is +-- whether the target is there. +validatePathText :: (FilePath -> PathTargetPresence) -> ConceptId -> FieldPath -> PathReferenceRule -> Text -> [ProfileViolation] +validatePathText presenceOf sourceConcept path policy rawPath = + case classifyPathReference sourceConcept rawPath of + ExternalUrl scheme + | scheme `elem` policy ^. #externalUriSchemes -> [] + | otherwise -> + [ExternalReferenceSchemeNotAllowed sourceConcept path scheme (policy ^. #externalUriSchemes)] + EscapesBundle -> [PathEscapesBundle sourceConcept path rawPath] + MalformedPath -> [MalformedPathReference sourceConcept path (String rawPath)] + BundlePath resolved + | FilePath.takeExtension resolved == ".md" -> + case conceptIdFromFilePath resolved of + Left _ -> [MalformedPathReference sourceConcept path (String rawPath)] + Right target + | target == sourceConcept, + not (policy ^. #allowSelf) -> + [SelfDocumentReference sourceConcept path rawPath] + | otherwise -> danglingWhenAbsent resolved + | otherwise -> danglingWhenAbsent resolved + where + danglingWhenAbsent resolved = case presenceOf resolved of + TargetAbsent -> [DanglingPathReference sourceConcept path rawPath] + TargetPresent -> [] + TargetUnknown -> [] + +appendArrayIndex :: FieldPath -> Int -> FieldPath +appendArrayIndex (FieldPath pathSegments) elementIndex = + FieldPath (pathSegments <> (ArrayIndex elementIndex :| [])) + +applicablePresenceClause :: ValidationProfile -> (Text -> Maybe Value) -> EffectiveFieldRule -> Maybe PresenceClause +applicablePresenceClause validationProfile lookupValue rule = + List.find applies requiredClauses + <|> if validationProfile == StrictAuthoring then List.find applies recommendedClauses else Nothing + where + requiredClauses = filter ((== RequiredField) . (^. #requirement)) (rule ^. #presenceClauses) + recommendedClauses = filter ((== RecommendedField) . (^. #requirement)) (rule ^. #presenceClauses) + applies clause = maybe True conditionApplies (clause ^. #condition) + conditionApplies condition = + case lookupValue (condition ^. #field) of + Just (String actual) -> actual `elem` condition ^. #hasValue + _ -> False + +valueMatchesVocabulary :: [Text] -> Value -> Bool +valueMatchesVocabulary allowed = \case + String value -> value `elem` allowed + Array values -> all elementMatches (Vector.toList values) + _ -> False + where + elementMatches (String value) = value `elem` allowed + elementMatches _ = False + +-- | Whether a present value satisfies a format. Each format declares which +-- value shapes it can match at all: the textual formats match a string, the +-- numeric ones a YAML number, and 'Boolean' a YAML boolean. A list is matched +-- by recursing, so a list of integers satisfies an @integer@ format for the +-- same reason a list of timestamps satisfies @rfc3339-utc@ — a format +-- constrains a value, and a list is a list of values. +valueMatchesFormat :: FieldFormat -> Value -> Bool +valueMatchesFormat fieldFormat actual = + case actual of + String value -> textMatchesFormat fieldFormat value + Array values -> all (valueMatchesFormat fieldFormat) (Vector.toList values) + Number _ -> numberMatchesFormat fieldFormat actual + Bool _ -> fieldFormat == Boolean + _ -> False + +textMatchesFormat :: FieldFormat -> Text -> Bool +textMatchesFormat fieldFormat value = + case fieldFormat of + Rfc3339Utc -> + hasExtendedUtcShape value + && isJust (iso8601ParseM (Text.unpack value) :: Maybe UTCTime) + Date -> + hasExtendedDateShape value + && isJust (iso8601ParseM (Text.unpack value) :: Maybe Day) + Uri -> isJust (parseURI (Text.unpack value)) + UriWithScheme expectedScheme -> + case parseURI (Text.unpack value) of + Just parsed -> + Text.toCaseFold (Text.dropWhileEnd (== ':') (Text.pack (uriScheme parsed))) + == Text.toCaseFold expectedScheme + Nothing -> False + DocumentHandle expectedPrefix -> + case parseDocumentId value of + Just documentId -> documentId ^. #prefix == expectedPrefix + Nothing -> False + -- Specification §7 defines exactly three actor shapes, and + -- 'Actor.parseActor' classifies them, so the format is a case match on its + -- result rather than a second parser. A value the convention does not + -- define — the specification's own illustrative @team:ga4-docs@ among them — + -- is 'Actor.UnclassifiedActor' and is reported. + Actor -> + case Actor.parseActor value of + Actor.UnclassifiedActor _ -> False + _ -> True + HumanActor -> Actor.isHumanActor (Actor.parseActor value) + -- A numeric or boolean format never matches text. A @usage_count: "5000"@ + -- is a quoted string in YAML and is reported rather than coerced, which is + -- the whole point of being able to declare the format. + Integer -> False + NonNegativeInteger -> False + Boolean -> False + +-- | Whether a YAML number satisfies a numeric format. Uses aeson's own +-- 'Integer' decoder, which already rejects a non-integral number, rather than +-- reaching for @scientific@: that package is a dependency of @aeson@ but not of +-- @okf-core@, so it is importable in a scratch experiment and not from here. +-- 'Okf.Document.objectInteger' takes the same route. +numberMatchesFormat :: FieldFormat -> Value -> Bool +numberMatchesFormat fieldFormat actual = + case Aeson.fromJSON actual :: Aeson.Result Integer of + Aeson.Error _ -> False + Aeson.Success parsed -> + case fieldFormat of + Integer -> True + NonNegativeInteger -> parsed >= 0 + _ -> False + +hasExtendedDateShape :: Text -> Bool +hasExtendedDateShape value = + Text.length value == 10 + && Text.index value 4 == '-' + && Text.index value 7 == '-' + +hasExtendedUtcShape :: Text -> Bool +hasExtendedUtcShape value = + Text.length value >= 20 + && Text.index value 4 == '-' + && Text.index value 7 == '-' + && Text.index value 10 == 'T' + && Text.index value 13 == ':' + && Text.index value 16 == ':' + && Text.last value == 'Z' + +data FieldValueEvaluation + = FieldAbsent (Maybe Value) + | FieldPresent Value + | FieldWrongShape Value + +-- | Decide whether a frontmatter value counts as present for one rule. Takes the +-- whole rule rather than just its cardinality because the 'Any' case has to know +-- whether the rule declares object members: a rule accepting both spellings of +-- the OKF v0.2 @verified@ key stays at 'Any' cardinality and must still count a +-- mapping as present. +-- +-- This is the single point at which okf decides presence, so a change here +-- affects every profile check. +evaluateFieldValue :: EffectiveFieldRule -> Maybe Value -> FieldValueEvaluation +evaluateFieldValue _ Nothing = FieldAbsent Nothing +evaluateFieldValue rule (Just actual) = + case rule ^. #cardinality of + Any + | legacyValueIsPresent actual -> FieldPresent actual + -- A rule that also accepts a mapping counts a non-empty one as present. + -- Without this a profile declaring both shapes would report `verified` + -- missing on a document that writes it as a bare mapping. + | isJust (rule ^. #objectFields), nonEmptyObject actual -> FieldPresent actual + | otherwise -> FieldAbsent (Just actual) + Scalar -> + case actual of + String value + | Text.null (Text.strip value) -> FieldAbsent (Just actual) + | otherwise -> FieldPresent actual + Number _ -> FieldPresent actual + Bool _ -> FieldPresent actual + _ -> FieldWrongShape actual + List -> + case actual of + Array values + | null values -> FieldAbsent (Just actual) + | otherwise -> FieldPresent actual + _ -> FieldWrongShape actual + Object + -- An empty mapping is treated as absent for the same reason an empty list + -- is: a key written with no content is the author saying nothing, and + -- reporting it missing is more useful than reporting it present and empty. + | nonEmptyObject actual -> FieldPresent actual + | isObject actual -> FieldAbsent (Just actual) + | otherwise -> FieldWrongShape actual + +isObject :: Value -> Bool +isObject = \case + Aeson.Object _ -> True + _ -> False + +nonEmptyObject :: Value -> Bool +nonEmptyObject = \case + Aeson.Object members -> not (Aeson.KeyMap.null members) + _ -> False + +legacyValueIsPresent :: Value -> Bool +legacyValueIsPresent = \case + String value -> not (Text.null (Text.strip value)) + Array values -> not (null values) + _ -> False + +-- | Check a profile-declared document ID for one concept. +checkDocumentId :: ProfileSpec -> ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] +checkDocumentId spec cid ctype rule concept = + case (spec ^. #idField, rule ^. #idPrefix) of + (Just fieldName, Just expectedPrefix) -> + case frontmatterLookup fieldName (conceptFrontmatter concept) of + Just (String value) + | not (Text.null (Text.strip value)) -> + case parseDocumentId value of + Just documentId + | documentId ^. #prefix == expectedPrefix -> [] + _ -> [MalformedDocumentId cid expectedPrefix value] + _ -> [MissingDocumentId cid ctype expectedPrefix] + _ -> [] + +-- | Check every non-empty value under the profile's ID field for bundle-wide +-- uniqueness. Concept IDs are sorted before grouping so output is deterministic. +checkDuplicateDocumentIds :: ProfileSpec -> [Concept] -> [ProfileViolation] +checkDuplicateDocumentIds spec concepts = + case spec ^. #idField of + Nothing -> [] + Just fieldName -> + concatMap duplicateViolations (groupedHandles fieldName) + where + groupedHandles fieldName = + List.groupBy + (\(leftHandle, _) (rightHandle, _) -> leftHandle == rightHandle) + (handles fieldName) + handles fieldName = + List.sortOn + (\(handle, cid) -> (handle, renderConceptId cid)) + [ (handle, conceptIdOf concept) + | concept <- concepts, + Just (String handle) <- [frontmatterLookup fieldName (conceptFrontmatter concept)], + not (Text.null (Text.strip handle)) + ] + duplicateViolations ((handle, firstConcept) : duplicates) = + [ DuplicateDocumentId handle firstConcept duplicateConcept + | (_, duplicateConcept) <- duplicates + ] + duplicateViolations [] = [] + +-- | Project a concept's frontmatter (the document's @frontmatter@ field). +conceptFrontmatter :: Concept -> Frontmatter +conceptFrontmatter concept = conceptDocument concept ^. #frontmatter + +-- | A type rule's @pathPattern@, when present, constrains where the concept's +-- file may live. +checkPath :: ConceptId -> Text -> TypeRule -> [ProfileViolation] +checkPath cid ctype rule = + case rule ^. #pathPattern of + Nothing -> [] + Just patternText + | matchPathPattern patternText cid -> [] + | otherwise -> [PathPatternMismatch cid ctype patternText] + +-- | Match a concept ID against a segment-glob pattern. @*@ matches exactly one +-- segment; a single trailing @**@ matches one or more remaining segments; every +-- other segment matches literally. Both segment lists must be consumed exactly, +-- except for the trailing @**@ case. +matchPathPattern :: Text -> ConceptId -> Bool +matchPathPattern patternText cid = + go (Text.splitOn "/" patternText) (Text.splitOn "/" (renderConceptId cid)) + where + go [] [] = True + go ["**"] (_ : _) = True + go ("*" : ps) (_ : ss) = go ps ss + go (p : ps) (s : ss) = p == s && go ps ss + go _ _ = False + +-- | A type rule's @resourceScheme@, when present, requires a @resource:@ value +-- whose scheme matches. +checkResource :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] +checkResource cid ctype rule concept = + case rule ^. #resourceScheme of + Nothing -> [] + Just scheme -> + case conceptResource concept of + Nothing -> [MissingResource cid ctype scheme] + Just value + | (scheme <> "://") `Text.isPrefixOf` value -> [] + | otherwise -> [ResourceSchemeMismatch cid scheme value] + +-- | A type rule's @# Schema@ contract: when @requireSchemaSection@ is set, the +-- body must contain a @# Schema@ section whose table header begins with the +-- required @schemaColumns@ (case-insensitive, trimmed, compared as a prefix so a +-- team may add trailing columns without tripping the check). +checkSchema :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] +checkSchema cid ctype rule concept + | not (rule ^. #requireSchemaSection) = [] + | otherwise = + case schemaSectionColumns (conceptDocument concept ^. #body) of + Nothing -> [MissingSchemaSection cid ctype] + Just actual -> + let expected = rule ^. #schemaColumns + norm = map (Text.toLower . Text.strip) + in [ SchemaColumnsMismatch cid ctype expected actual + | not (norm expected `List.isPrefixOf` norm actual) + ] + +-- | The header-row columns of the first GitHub-flavored table that follows the +-- first top-level @# Schema@ heading, or 'Nothing' if there is no Schema heading +-- or no following table. Columns are trimmed. +schemaSectionColumns :: Text -> Maybe [Text] +schemaSectionColumns markdown = + let CMarkGFM.Node _ _ topLevel = CMarkGFM.commonmarkToNode markdownOptions [CMarkGFM.extTable] markdown in firstTableAfterSchema topLevel firstTableAfterSchema :: [CMarkGFM.Node] -> Maybe [Text] diff --git a/src/Okf/Profile/Documentation.hs b/src/Okf/Profile/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Profile/Documentation.hs @@ -0,0 +1,586 @@ +{-# LANGUAGE PackageImports #-} + +-- | Render an OKF profile as an OKF bundle that documents it. +-- +-- A profile describes a team's house conventions for a directory tree of +-- Markdown documents. It can be read as Dhall source or dumped by +-- @okf profile show@, but neither form is something a team browses, links to, +-- or reviews in a pull request. 'renderProfileDocumentation' turns a compiled +-- profile into ordinary 'Concept's: a root document describing the profile as a +-- whole plus one document per declared concept type, cross-linked with +-- bundle-absolute Markdown links. Because the result is an ordinary OKF bundle, +-- every tool okf ships works on it — @okf validate@, @okf graph@, @okf show@, +-- @okf index@ — and so does any downstream OKF consumer. +-- +-- Rules are rendered from the /compiled/ profile, so each type's page shows the +-- profile-scope and type-scope declarations already merged per +-- [ADR 5](docs/adr/5-compile-profile-rules-before-validation.md). A reader +-- learns what actually applies to a concept of that type rather than having to +-- compose two declaration sites in their head. +-- +-- == The published output contract +-- +-- Other tools key on the following, so it is stated here rather than left to be +-- inferred from the code. In particular +-- @docs/profiles/profile-documentation.dhall@ encodes the same contract in +-- Dhall; any change here must change that descriptor in the same commit. +-- +-- * The root concept's ID is 'rootConceptId', default @profile@. +-- * Each type concept's ID is @\\/\@, default directory +-- @types@, where the slug is 'profileDocumentationSlug' of the declared +-- @type@ string, with @type-N@ substituted when that slug is empty and @-N@ +-- appended on collision, @N@ being the one-based declaration index. +-- * The root concept's frontmatter @type@ is 'profileConceptType' +-- (@OKF Profile@); each type concept's is 'profileTypeConceptType' +-- (@OKF Profile Type@). Both are exported as constants so a consumer keys on +-- the constant rather than a literal. +-- * Every generated concept carries @type@, @title@, and @description@. It +-- carries @generated@ if and only if 'generated' is 'Just', which it is by +-- default, naming 'defaultDocumentationActor'. It carries the superseded +-- v0.1 @timestamp@ if and only if 'timestamp' is 'Just', which it is not by +-- default. It carries no other frontmatter key — in particular no +-- @resource@ and no @tags@. +-- * @title@ on a type concept is the profile's @type@ string verbatim, not the +-- slug: the title is what a reader must write in their own frontmatter. +-- * Every cross-link is bundle-absolute and produced by +-- 'Okf.ConceptId.renderConceptLink', so 'Okf.Graph.buildGraph' resolves it and +-- 'Okf.Validation.validateBundle' finds no dangling reference. +-- * Output is a deterministic function of the compiled profile and the options. +-- Nothing reads the clock, the environment, or the filesystem — in +-- particular @generated.at@ is whatever the caller passes and is absent by +-- default — so generated documentation can be committed and used as a CI +-- drift check. +module Okf.Profile.Documentation + ( DocumentationOptions (..), + defaultDocumentationOptions, + defaultDocumentationActor, + DocumentationError (..), + profileConceptType, + profileTypeConceptType, + profileDocumentationSlug, + renderProfileDocumentation, + ) +where + +import Data.Char qualified as Char +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Okf.Actor (Actor (..)) +import Okf.Bundle +import Okf.ConceptId +import Okf.Document +import Okf.Prelude hiding (List) +import Okf.Profile +import "generic-lens" Data.Generics.Labels () + +-- | How to lay out a generated documentation bundle. Start from +-- 'defaultDocumentationOptions' and override what you need, so that later +-- additions to this record do not break your call site. +data DocumentationOptions = DocumentationOptions + { -- | Concept ID of the document describing the profile as a whole. + rootConceptId :: !Text, + -- | Directory holding one document per declared concept type. + typeDirectory :: !Text, + -- | Value for the @timestamp@ frontmatter key on every generated document. + -- 'Nothing' omits the key entirely. The generator never reads the clock: + -- output must be byte-identical across runs so it can be committed and + -- diffed. Note that 'Okf.Validation.StrictAuthoring' requires a timestamp, + -- so a caller wanting strict-clean output must supply one. Superseded by + -- 'generated', which 'defaultDocumentationOptions' supplies instead. + timestamp :: !(Maybe Text), + -- | The OKF v0.2 @generated@ family (specification §5.2) written on every + -- generated document. 'Nothing' omits the key entirely, which produces a + -- bundle that 'Okf.Validation.StrictAuthoring' reports as missing + -- provenance; 'defaultDocumentationOptions' therefore supplies one. + -- + -- The generator still never reads the clock: @generatedAt@ is whatever the + -- caller passes and is 'Nothing' by default, so two runs of the same + -- command produce identical bytes. + generated :: !(Maybe Generated) + } + deriving stock (Generic, Eq, Show) + +-- | The actor 'defaultDocumentationOptions' names as the producer of a +-- generated documentation bundle: @process:okf-profile-document@. +-- +-- Deliberately carries no version. Specification §7 would also permit +-- @okf\/\@, but generated documentation is meant to be committed and +-- checked with @git diff --exit-code@, and a version-bearing default would +-- change every generated byte on every okf release. A caller who wants the +-- producing version passes it explicitly. +defaultDocumentationActor :: Actor +defaultDocumentationActor = ProcessActor "okf-profile-document" + +-- | The default layout: a root document at @profile@ and one document per type +-- under @types/@, with no v0.1 timestamp and a @generated@ family naming +-- 'defaultDocumentationActor'. +defaultDocumentationOptions :: DocumentationOptions +defaultDocumentationOptions = + DocumentationOptions + { rootConceptId = "profile", + typeDirectory = "types", + timestamp = Nothing, + generated = Just (Generated defaultDocumentationActor Nothing) + } + +-- | The only way generation can fail: a caller supplied a layout option that is +-- not a legal concept path. No profile can cause a failure — slugging is total +-- and collisions are resolved positionally — so a profile that compiles always +-- documents. +data DocumentationError + = InvalidRootConceptId !Text !ConceptIdError + | InvalidTypeDirectory !Text !ConceptIdError + deriving stock (Generic, Eq, Show) + +-- | The @type@ frontmatter value on the document describing a profile. +profileConceptType :: Text +profileConceptType = "OKF Profile" + +-- | The @type@ frontmatter value on each document describing one declared +-- concept type. +profileTypeConceptType :: Text +profileTypeConceptType = "OKF Profile Type" + +-- | Turn a free-text profile @type@ string into a concept-ID segment. +-- +-- ASCII letters are lowercased; every character that is not an ASCII letter or +-- digit becomes a hyphen; runs of hyphens collapse to one; leading and trailing +-- hyphens are dropped. @\"BigQuery Table\"@ becomes @\"bigquery-table\"@ and +-- @\"C++ Header\"@ becomes @\"c-header\"@. +-- +-- The result is empty when the input contains no ASCII alphanumeric character +-- at all. 'renderProfileDocumentation' substitutes a positional fallback, +-- @type-N@ for the Nth declared type counting from one, in that case, and +-- disambiguates two type strings that slug identically by appending @-N@ to the +-- later one. Both fallbacks are deterministic functions of declaration order. +profileDocumentationSlug :: Text -> Text +profileDocumentationSlug raw = + Text.intercalate "-" (filter (not . Text.null) pieces) + where + pieces = Text.split (not . isSlugChar) (Text.map Char.toLower raw) + isSlugChar character = + Char.isAsciiLower character + || Char.isAsciiUpper character + || Char.isDigit character + +-- | Render a compiled profile as a list of concepts: the root profile concept +-- first, then one concept per declared type in profile declaration order. +-- +-- Total on the profile side. See the module header for the output contract. +renderProfileDocumentation :: + DocumentationOptions -> + CompiledProfile -> + Either DocumentationError [Concept] +renderProfileDocumentation options compiled = do + (rootId, typeLayout) <- documentationLayout options compiled + let rootConcept = renderRootConcept options compiled rootId typeLayout + typeConcepts = + [ renderTypeConcept options compiled rootId typeName typeConceptId + | (typeName, typeConceptId) <- typeLayout + ] + pure (rootConcept : typeConcepts) + +-- | The root concept ID and, for each declared type in declaration order, its +-- name paired with its concept ID. +documentationLayout :: + DocumentationOptions -> + CompiledProfile -> + Either DocumentationError (ConceptId, [(Text, ConceptId)]) +documentationLayout options compiled = do + rootId <- first (InvalidRootConceptId rawRoot) (parseConceptId rawRoot) + _validDirectory <- first (InvalidTypeDirectory rawDirectory) (parseConceptId rawDirectory) + pure (rootId, assignSlugs Set.empty (zip [1 :: Int ..] (compiledProfileTypeNames compiled))) + where + rawRoot = options ^. #rootConceptId + rawDirectory = options ^. #typeDirectory + + assignSlugs _used [] = [] + assignSlugs used ((declarationIndex, typeName) : remaining) = + let slug = uniqueSlug used declarationIndex (profileDocumentationSlug typeName) + in (typeName, typeConceptIdFor slug) : assignSlugs (Set.insert slug used) remaining + + -- The slug is ASCII alphanumerics and hyphens and the directory has already + -- parsed as a concept path, so this parse cannot fail. Fail loudly rather + -- than silently if a future change breaks that invariant. + typeConceptIdFor slug = + case parseConceptId (rawDirectory <> "/" <> slug) of + Right conceptId -> conceptId + Left err -> + error + ( "Okf.Profile.Documentation: internal invariant broken, " + <> "a validated type directory and a slug produced an invalid " + <> "concept ID: " + <> show err + ) + +-- | Pick a slug not yet used: the natural slug, else @type-N@ when it is empty, +-- else the stem with an increasing numeric suffix starting at the declaration +-- index. Deterministic in declaration order. +uniqueSlug :: Set Text -> Int -> Text -> Text +uniqueSlug used declarationIndex base = go Nothing + where + stem = if Text.null base then "type-" <> renderInt declarationIndex else base + go suffix = + let candidate = maybe stem (\n -> stem <> "-" <> renderInt n) suffix + in if Set.member candidate used + then go (Just (maybe declarationIndex (+ 1) suffix)) + else candidate + +renderInt :: Int -> Text +renderInt = Text.pack . show + +-- * The root profile concept + +renderRootConcept :: + DocumentationOptions -> + CompiledProfile -> + ConceptId -> + [(Text, ConceptId)] -> + Concept +renderRootConcept options compiled rootId typeLayout = + conceptFromDocument rootId (OKFDocument frontmatter body) + where + spec = compiledProfileSpec compiled + profileName = spec ^. #name + declaredDescription = nonBlank (spec ^. #description) + frontmatter = + withGenerated options $ + okfCommon + OkfCommon + { commonType = profileConceptType, + commonTitle = Just profileName, + commonDescription = Just (effectiveProfileDescription spec), + commonTimestamp = options ^. #timestamp + } + body = + unlinesText $ + ["# " <> profileName, ""] + -- Only the profile's own prose goes in the body. The synthesized + -- fallback exists to keep the frontmatter strict-clean; repeating it + -- here would tell the reader nothing they cannot see in the heading. + <> maybe [] (\prose -> [prose, ""]) declaredDescription + <> [ "## Settings", + "", + "- OKF version: " <> code (spec ^. #okfVersion), + "- Required bundle version: " <> maybe "none" code (spec ^. #requireBundleVersion), + "- Unknown concept types: " <> permitted (spec ^. #allowUnknownTypes), + "- Unknown frontmatter keys: " <> permitted (spec ^. #allowUnknownFields), + "- Document ID field: " <> maybe "none" code (spec ^. #idField), + "", + "## Frontmatter rules", + "", + "These rules apply to every concept in a bundle governed by this profile,", + "whatever its type. Each concept type's own page repeats them merged with that", + "type's rules, which is the form that actually applies.", + "" + ] + <> baseRuleLines + <> [ "## Concept types", + "" + ] + <> typeLines + + baseRuleLines = + case Map.toAscList (compiledProfileBaseRules compiled) of + [] -> ["(none declared)", ""] + rules -> concatMap (uncurry (renderFieldRule 3)) rules + + typeLines + | null typeLayout = ["(none declared)"] + | otherwise = + [ "- " <> renderConceptLink typeConceptId typeName <> descriptionSuffix typeName + | (typeName, typeConceptId) <- typeLayout + ] + + typeDescriptions = + Map.fromList + [ (rule ^. #type_, nonBlank (rule ^. #description)) + | rule <- spec ^. #types + ] + + descriptionSuffix typeName = + case Map.lookup typeName typeDescriptions of + Just (Just prose) -> " — " <> prose + _ -> "" + + permitted allowed = if allowed then "allowed" else "rejected" + +-- * One concept per declared type + +renderTypeConcept :: + DocumentationOptions -> + CompiledProfile -> + ConceptId -> + Text -> + ConceptId -> + Concept +renderTypeConcept options compiled rootId typeName typeConceptId = + conceptFromDocument typeConceptId (OKFDocument frontmatter body) + where + spec = compiledProfileSpec compiled + profileName = spec ^. #name + typeRule = + Map.lookup typeName (Map.fromList [(rule ^. #type_, rule) | rule <- spec ^. #types]) + description = + case typeRule >>= (nonBlank . (^. #description)) of + Just prose -> prose + Nothing -> + "Concept type \"" + <> typeName + <> "\" as declared by the " + <> profileName + <> " profile." + frontmatter = + withGenerated options $ + okfCommon + OkfCommon + { commonType = profileTypeConceptType, + commonTitle = Just typeName, + commonDescription = Just description, + commonTimestamp = options ^. #timestamp + } + rules = compiledProfileRulesForType compiled typeName + body = + unlinesText $ + ["# " <> typeName, ""] + -- As on the profile page, only the type rule's own prose is repeated + -- in the body; the synthesized fallback is frontmatter-only. + <> maybe [] (\prose -> [prose, ""]) (typeRule >>= (nonBlank . (^. #description))) + <> [ "Declared by the " <> renderConceptLink rootId profileName <> " profile.", + "", + "## Type settings", + "", + "- Path pattern: " <> maybe "none" code (typeRule >>= (^. #pathPattern)), + "- Resource URI scheme: " <> maybe "none" code (typeRule >>= (^. #resourceScheme)), + "- Requires a `# Schema` section: " <> yesNo (maybe False (^. #requireSchemaSection) typeRule), + "- Schema columns: " <> codeListOr "none" (maybe [] (^. #schemaColumns) typeRule), + "- Document ID prefix: " <> maybe "none" code (typeRule >>= (^. #idPrefix)), + "", + "## Frontmatter rules", + "", + "Every rule below is the effective rule for a concept of type " + <> code typeName + <> ":", + "the profile-wide rule and this type's own rule, already merged.", + "" + ] + <> group "Required" (Map.toAscList (Map.filter ((== PresenceRequired) . presenceClassOf) rules)) + <> group "Recommended" (Map.toAscList (Map.filter ((== PresenceRecommended) . presenceClassOf) rules)) + <> group "Optional" (Map.toAscList (Map.filter ((== PresenceOptional) . presenceClassOf) rules)) + + group heading [] = ["### " <> heading, "", "(none)", ""] + group heading members = + ["### " <> heading, ""] <> concatMap (uncurry (renderFieldRule 4)) members + + yesNo condition = if condition then "yes" else "no" + +-- * Rendering one field rule + +-- | Which section of a type page a rule belongs in. A rule is Required if any +-- of its presence clauses demands the key, Recommended if it has any clause at +-- all, and Optional when it has none — the empty-clause encoding ADR 5 chose +-- for the third presence class. +data PresenceClass = PresenceRequired | PresenceRecommended | PresenceOptional + deriving stock (Eq, Show) + +presenceClassOf :: EffectiveFieldRule -> PresenceClass +presenceClassOf rule = + case fieldRulePresenceClauses rule of + [] -> PresenceOptional + clauses + | any isRequired clauses -> PresenceRequired + | otherwise -> PresenceRecommended + where + isRequired clause = presenceClauseRequirement clause == RequiredField + +-- | The lines documenting one frontmatter key, at the given heading level: a +-- heading naming the key and its presence, the key's prose when it has any, +-- then a fixed bullet list of value constraints so the shape never shifts. +renderFieldRule :: Int -> Text -> EffectiveFieldRule -> [Text] +renderFieldRule level key rule = + [ Text.replicate level "#" <> " " <> code key <> " — " <> presencePhrase rule, + "" + ] + <> maybe [] (\prose -> [prose, ""]) (nonBlank (fieldRuleDescription rule)) + <> constraintBullets + <> [""] + where + constraintBullets = + [ "- Allowed values: " <> codeListOr "any" (fieldRuleAllowedValues rule), + "- Cardinality: " <> renderCardinalityName (fieldRuleCardinality rule), + "- Format: " <> maybe "none" renderFieldFormatName (fieldRuleFormat rule), + "- Reference: " <> maybe "none" renderReference (fieldRuleReference rule), + "- Path: " <> maybe "none" renderPathRule (fieldRulePath rule) + ] + <> conditionBullets + <> objectFieldBullets + <> elementFieldBullets + <> strictNote + + conditionBullets = + case [clause | clause <- fieldRulePresenceClauses rule, isJust (presenceClauseCondition clause)] of + [] -> ["- Condition: none"] + [single] -> ["- Condition: applies only when " <> clausePhrase single] + many_ -> + ["- Condition:"] + <> [" - applies only when " <> clausePhrase clause | clause <- many_] + + clausePhrase clause = + maybe "always" conditionPhrase (presenceClauseCondition clause) + + -- The members of the mapping that *is* the value, as opposed to the members + -- of each element of a list. A rule may declare both, in which case both + -- bullets carry content and either spelling of the value is accepted. + objectFieldBullets = + case fieldRuleObjectFields rule of + Nothing -> ["- Object fields: none"] + Just members -> + ["- Object fields:"] + <> [" - " <> renderElementField memberKey memberRule | (memberKey, memberRule) <- Map.toAscList members] + + elementFieldBullets = + case fieldRuleElementFields rule of + Nothing -> ["- Element fields: none"] + Just nested -> + ["- Element fields:"] + <> [" - " <> renderElementField nestedKey nestedRule | (nestedKey, nestedRule) <- Map.toAscList nested] + + strictNote = + case presenceClassOf rule of + PresenceRecommended -> ["- Checked only under `--strict`"] + _ -> [] + +-- | Nested element rules are depth-bounded at one level, so this is flat by +-- construction: 'fieldRuleElementFields' on a nested rule is always 'Nothing'. +-- +-- The path clause is emitted only when the member declares one, unlike the +-- fixed bullet list of 'renderFieldRule'. This line is already a dense +-- semicolon-separated run and a member declares no path policy far more often +-- than not, so a @path: none@ on every member of every record would cost more +-- than it says. A nested path policy is nevertheless the motivating case for +-- path rules — @sources[].resource@ lives here — so it must be visible when it +-- is there. +renderElementField :: Text -> EffectiveFieldRule -> Text +renderElementField key rule = + code key + <> " — " + <> Text.intercalate + "; " + ( [ presencePhrase rule, + "allowed values: " <> codeListOr "any" (fieldRuleAllowedValues rule), + "cardinality: " <> renderCardinalityName (fieldRuleCardinality rule), + "format: " <> maybe "none" renderFieldFormatName (fieldRuleFormat rule) + ] + <> foldMap (\policy -> ["path: " <> renderPathRule policy]) (fieldRulePath rule) + ) + <> maybe "" (" — " <>) (nonBlank (fieldRuleDescription rule)) + +-- | How a key's presence reads in a heading: @required@, @recommended@, +-- @optional@, or @required when \`status\` is \`superseded\`@. +presencePhrase :: EffectiveFieldRule -> Text +presencePhrase rule = + case fieldRulePresenceClauses rule of + [] -> "optional" + clauses -> + let required = [clause | clause <- clauses, presenceClauseRequirement clause == RequiredField] + unconditionalRequired = + [clause | clause <- required, isNothing (presenceClauseCondition clause)] + in case (unconditionalRequired, required) of + (_ : _, _) -> "required" + ([], firstRequired : _) -> + "required when " <> maybe "always" conditionPhrase (presenceClauseCondition firstRequired) + ([], []) -> "recommended" + +-- | A same-scope predicate in prose: @\`status\` is \`superseded\`@, or +-- @\`status\` is one of \`a\`, \`b\`@ for more than one accepted value. +conditionPhrase :: FieldCondition -> Text +conditionPhrase condition = + case condition ^. #hasValue of + [] -> code (condition ^. #field) <> " has any value" + [single] -> code (condition ^. #field) <> " is " <> code single + values -> code (condition ^. #field) <> " is one of " <> codeListOr "any" values + +renderReference :: HandleReferenceRule -> Text +renderReference policy = + Text.intercalate + "; " + [ "local handles with prefix " <> code (policy ^. #localPrefix), + externalPhrase, + if policy ^. #allowSelf then "self-reference allowed" else "self-reference not allowed" + ] + where + externalPhrase = + case policy ^. #externalUriSchemes of + [] -> "external URIs not allowed" + [single] -> "external URIs with scheme " <> code single + schemes -> "external URIs with schemes " <> codeListOr "any" schemes + +-- | A path policy in prose, deliberately parallel to 'renderReference' so the +-- two rule kinds read as siblings. It says what okf resolves as well as what it +-- permits, because the @.md@-only existence check is the surprising part. +renderPathRule :: PathReferenceRule -> Text +renderPathRule policy = + Text.intercalate + "; " + [ "bundle paths resolved to concepts", + externalPhrase, + if policy ^. #allowSelf then "self-reference allowed" else "self-reference not allowed" + ] + where + externalPhrase = + case policy ^. #externalUriSchemes of + [] -> "external URLs not allowed" + [single] -> "external URLs with scheme " <> code single + schemes -> "external URLs with schemes " <> codeListOr "any" schemes + +-- * Small shared helpers + +-- | Add the OKF v0.2 @generated@ family when the options carry one. Written +-- through 'Okf.Document.setGenerated' so this module never learns that +-- @generated@ is a mapping of an actor and a datetime. +withGenerated :: DocumentationOptions -> Frontmatter -> Frontmatter +withGenerated options = maybe id setGenerated (options ^. #generated) + +-- | The profile's own prose, or a synthesized sentence when it declares none. +-- Generated documents always carry a @description@ so that they pass +-- 'Okf.Validation.StrictAuthoring', which most profiles' own prose would not +-- guarantee today. +effectiveProfileDescription :: ProfileSpec -> Text +effectiveProfileDescription spec = + case nonBlank (spec ^. #description) of + Just prose -> prose + Nothing -> + "OKF profile \"" + <> spec ^. #name + <> "\" declaring " + <> conceptTypeCountPhrase (length (spec ^. #types)) + <> "." + +conceptTypeCountPhrase :: Int -> Text +conceptTypeCountPhrase = \case + 0 -> "no concept types" + 1 -> "1 concept type" + n -> renderInt n <> " concept types" + +-- | 'Nothing' for an absent or all-whitespace value, so a profile that declares +-- @description = Some \"\"@ is treated the same as one that declares none. +nonBlank :: Maybe Text -> Maybe Text +nonBlank value = do + raw <- value + let trimmed = Text.strip raw + if Text.null trimmed then Nothing else Just trimmed + +code :: Text -> Text +code value = "`" <> value <> "`" + +-- | A comma-separated list of backticked values, or the given word when empty. +codeListOr :: Text -> [Text] -> Text +codeListOr emptyWord = \case + [] -> emptyWord + values -> Text.intercalate ", " (map code values) + +-- | Join body lines, giving the body a single trailing newline. +unlinesText :: [Text] -> Text +unlinesText = Text.unlines diff --git a/src/Okf/Trust.hs b/src/Okf/Trust.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Trust.hs @@ -0,0 +1,120 @@ +-- | Trust and freshness derivations for OKF v0.2 concepts. +-- +-- Everything here is __derived on read and never stored__. Specification §5.3 +-- says "Consumers /derive/ a trust tier", and §5.1 says credibility "is +-- /inferred/ from the signals, the same way trust tiers are (§5.3), not +-- stored". Accordingly this module exports plain functions over frontmatter +-- values rather than fields on 'Okf.Bundle.Concept': a stored derivation can go +-- stale relative to the frontmatter it summarises, which the projection +-- contract on @Okf.Bundle.conceptAt@ already forbids. See +-- @docs\/adr\/8-derived-not-stored-trust-and-credibility.md@. +-- +-- This module also never reads the clock. 'staleness' takes the current day as +-- an argument so it stays pure and testable against a fixed date, and so that +-- two calls in one run cannot disagree about what "today" is. The command-line +-- tool reads the clock once and passes the day down. +module Okf.Trust + ( TrustTier (..), + trustTier, + renderTrustTier, + latestVerification, + Staleness (..), + staleness, + renderStaleness, + ) +where + +import Data.Text qualified as Text +import Data.Time (Day, defaultTimeLocale, parseTimeM) +import Okf.Actor (isHumanActor) +import Okf.Document (Verification (..)) +import Okf.Prelude + +-- | A concept's trust tier, lowest to highest, per specification §5.3. +-- +-- Tiers are advisory signals, not access control: §5.3 states that "A concept +-- with no trust frontmatter is still consumable; consumers MUST NOT reject it". +-- The 'Ord' instance orders them lowest to highest so callers can compare. +data TrustTier + = -- | No usable @verified@ entry. + Unverified + | -- | Verified by non-@human:@ actors only. + MachineConfirmed + | -- | Verified by at least one @human:\@ actor. + HumanReviewed + deriving stock (Generic, Eq, Ord, Show) + +-- | Derive a trust tier from a concept's @verified@ entries, per §5.3. +-- +-- The @human:@ test comes from 'Okf.Actor.isHumanActor' rather than being +-- re-derived here: §5.3 makes that single test the sole discriminator between +-- the two verified tiers, and two copies of it would eventually disagree. +trustTier :: [Verification] -> TrustTier +trustTier verifications + | null verifications = Unverified + | any (isHumanActor . verificationBy) verifications = HumanReviewed + | otherwise = MachineConfirmed + +-- | Render a tier in the specification's own words, so CLI output and +-- documentation match §5.3 for a reader with the specification open. +renderTrustTier :: TrustTier -> Text +renderTrustTier = \case + Unverified -> "unverified" + MachineConfirmed -> "machine-confirmed" + HumanReviewed -> "human-reviewed" + +-- | The most recent verification time, implementing §5.2's "'How recently' is +-- the latest @at@". Entries without an @at@ are skipped. +-- +-- Compares the raw strings. ISO 8601 datetimes in a fixed-width UTC form sort +-- lexicographically in chronological order, the same shortcut +-- @Okf.Validation@ already takes for log dates. This breaks if a producer +-- writes a non-UTC offset such as @2026-06-25T09:00:00+01:00@, which sorts by +-- its local wall-clock reading rather than its instant. Profiles can require +-- the UTC form with the existing @Rfc3339Utc@ field format. +latestVerification :: [Verification] -> Maybe Text +latestVerification verifications = + case [occurredAt | Verification {verificationAt = Just occurredAt} <- verifications] of + [] -> Nothing + times -> Just (maximum times) + +-- | Whether a concept has passed its @stale_after@ date (specification §5.5). +data Staleness + = -- | @stale_after@ is present and today is before it. + Fresh + | -- | Today is on or after @stale_after@, which is carried here. + Stale !Day + | -- | @stale_after@ is present but is not a @YYYY-MM-DD@ date. The original + -- text is preserved so a caller can report it. + StaleAfterUnparseable !Text + | -- | No @stale_after@ key, so freshness is unknown rather than assured. + NoStaleAfter + deriving stock (Generic, Eq, Show) + +-- | Decide staleness against a caller-supplied day. +-- +-- Implements §5.5 literally: "A concept is stale when @today >= stale_after@". +-- The comparison is inclusive, so a concept whose @stale_after@ is exactly +-- today is stale. +-- +-- A value that does not parse yields 'StaleAfterUnparseable' rather than being +-- treated as fresh. Silently ignoring a malformed freshness deadline is the +-- worst available behaviour: it reports a concept as trustworthy on the +-- strength of a field nobody could read. +staleness :: Day -> Maybe Text -> Staleness +staleness today = \case + Nothing -> NoStaleAfter + Just raw -> + case parseTimeM True defaultTimeLocale "%Y-%m-%d" (Text.unpack raw) of + Nothing -> StaleAfterUnparseable raw + Just deadline + | today >= deadline -> Stale deadline + | otherwise -> Fresh + +-- | Render staleness as a short phrase for command-line output. +renderStaleness :: Staleness -> Text +renderStaleness = \case + Fresh -> "ok" + NoStaleAfter -> "ok" + Stale deadline -> "stale since " <> Text.pack (show deadline) + StaleAfterUnparseable raw -> "unparseable stale_after " <> raw diff --git a/src/Okf/Validation.hs b/src/Okf/Validation.hs --- a/src/Okf/Validation.hs +++ b/src/Okf/Validation.hs @@ -4,6 +4,9 @@ ValidationProfile (..), validateDocument, BundleValidationError (..), + VersionGate (..), + versionGate, + gateDeclaresAtLeast, validateBundle, validateBundleLogs, validateLogs, @@ -13,14 +16,38 @@ ) where +import Data.Aeson.Key qualified as AesonKey +import Data.Aeson.KeyMap qualified as KeyMap import Data.List qualified as List import Data.Text qualified as Text import Data.Vector qualified as Vector -import Okf.Bundle (Concept, LogFile, conceptDocument, conceptIdOf, conceptSourcePath, logContent, logSourcePath) +import Okf.Bundle + ( BundleInventory, + Concept, + LogFile, + bundleInventoryMember, + conceptAttester, + conceptComputation, + conceptDocument, + conceptExecutor, + conceptIdOf, + conceptResource, + conceptSourcePath, + logContent, + logSourcePath, + ) import Okf.ConceptId (ConceptId) import Okf.Document import Okf.Graph (danglingReferences, duplicateConceptIds) +import Okf.Index + ( OkfVersion (..), + VersionDeclaration (..), + renderOkfVersion, + supportedOkfVersion, + ) import Okf.Log (Log (logDays), LogDay (logDate), LogValidationError, validateLog) +import Okf.Markdown (extractFootnoteLabels, footnoteLabelsUsed) +import Okf.Path (PathResolution (..), resolvePathReference) import Okf.Prelude import System.FilePath qualified as FilePath @@ -36,6 +63,73 @@ | FieldMustBeNonEmptyText Text | MissingRecommendedField Text | FieldMustBeListOfText Text + | -- | Neither the OKF v0.2 @generated@ family (§5.2) nor the legacy v0.1 + -- @timestamp@ it supersedes (§13.1) records when the content last changed. + MissingGeneratedField + | -- | @generated@ is present but carries no textual @by@ actor, which + -- specification §5.2 marks REQUIRED within the mapping. + GeneratedMustHaveActor + | -- | A @sources@ entry omits the @resource@ that specification §5.1 marks + -- REQUIRED within an entry. Carries the entry's zero-based index in the raw + -- YAML list, which is the only way to name an entry that may have no @id@. + SourceMissingResource Int + | -- | Two @sources@ entries in one document share an @id@. + DuplicateSourceId Text + | -- | The body attributes a claim with a footnote label that names no + -- @sources@ entry in the same document, so the attribution resolves to + -- nothing. Specification §5.1 makes the label the join key into @sources@. + FootnoteLabelNotInSources Text + | -- | A @sources@ entry carries an @id@ that no footnote in the body cites. + -- A lint rather than a defect: §5.1 says an @id@ SHOULD be present when the + -- body cites the source, which implies an id exists in order to be cited, + -- but never requires the citation. + SourceIdNotCited Text + | -- | A concept carries a superseded OKF v0.1 construct in a bundle whose + -- root index declares OKF v0.2 or later. Carries the legacy field's name. + -- Reading the legacy construct still works — see + -- @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ — but a bundle that has + -- said it targets v0.2 is describing an authoring mistake rather than + -- exercising a compatibility path. + LegacyFieldInDeclaredV2 Text + | -- | A concept declaring @type: Attested Computation@ carries no @runtime@, + -- which specification §10.2 marks REQUIRED for that type — it is "the single + -- field that says how to run the computation, and so how the executor and + -- attester interpret it and what @parameters@ mean", so without it a + -- parameter has no binding semantics at all. + -- + -- Strict-only. §11's conformance list has three items and none is a + -- computation field, and §11 separately says a consumer "MUST NOT reject a + -- bundle because of ... Unknown @type@ values". "REQUIRED for this type" + -- binds the producer; it does not license a consumer to refuse. This is + -- therefore an authoring lint, placed exactly where + -- @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ places every other + -- optional-family presence check. + AttestedComputationMissingRuntime + | -- | A concept declaring @type: Attested Computation@ offers no computation + -- at all: no @computation@ path and no code block under @# Computation@. + -- Specification §10.3 says the computation is provided in one of two ways, + -- so a contract carrying neither promises a sanctioned computation and then + -- does not carry one. + -- + -- Strict-only, for the reason 'AttestedComputationMissingRuntime' gives. + AttestedComputationHasNoComputation + | -- | The concept offers both a @computation@ path and a body block. + -- Specification §10.3 permits exactly one — "set @computation@ to a path + -- (§6.2) and omit the body fence" — and two leaves a consumer with no way to + -- know which one the producer sanctioned. + -- + -- Strict-only, for the reason 'AttestedComputationMissingRuntime' gives. + AttestedComputationHasBothComputations + | -- | The @# Computation@ section holds more than one code block, where + -- specification §10.3 says "a single fenced code block". Carries the count, + -- so the diagnostic can say how many were found. + -- + -- The section is bounded at the next heading of the same or a shallower + -- level, so a code block under a later heading is not counted here; see + -- 'Okf.Markdown.computationBlocks'. + -- + -- Strict-only, for the reason 'AttestedComputationMissingRuntime' gives. + AttestedComputationHasManyBlocks Int deriving stock (Generic, Eq, Show) -- | A whole-bundle validation problem. @@ -44,13 +138,111 @@ DocumentInvalid ConceptId ValidationError | -- | A source concept links to a target that is not present in the bundle. DanglingReference ConceptId ConceptId + | -- | A path-valued frontmatter field (specification §6.2) names a bundle path + -- that no file in the bundle matches. Carries the concept, the frontmatter + -- field path as written (@resource@, or @executor.resource@), the resolved + -- bundle-relative target, and — when the value was relative and the same text + -- read as bundle-relative /would/ resolve — that alternative target. + -- + -- The fourth field exists because specification §10.2's own worked example + -- writes @executor.resource: references\/skills\/run-on-bq.md@ while §10.4 + -- puts computations under @computations\/@, so an author copying the + -- specification writes a relative path that names + -- @computations\/references\/...@ and is told about a path they did not + -- write. §6.2 resolution is correct and unchanged; the diagnostic simply says + -- what the author almost certainly meant. See + -- @docs\/adr\/13-the-references-convention-and-non-markdown-files.md@. + -- + -- Distinct from 'DanglingReference', which reports a Markdown link in a + -- concept /body/ naming a missing /concept/. A frontmatter path may name a + -- file that is not a concept at all — §6.3's @references\/attesters\/ + -- revenue.py@ — so it cannot be reported as a 'ConceptId' pair. + -- + -- Like 'DanglingReference' this is an authoring-time lint that goes beyond + -- conformance: §11 says a consumer MUST NOT reject a bundle over a broken + -- cross-link, because §6.1 permits a link to knowledge not yet written. + DanglingFrontmatterPath ConceptId Text FilePath (Maybe FilePath) | -- | The same concept ID was assembled more than once. DuplicateConceptId ConceptId | -- | A reserved log file does not match the required log structure. LogInvalid FilePath LogValidationError + | -- | The bundle root's @index.md@ carries an @okf_version@ whose value is + -- not of the form @\.\@ (specification §12). + BundleVersionUnparseable Text + | -- | The bundle declares a version with a major okf does not know. Per §12 + -- the bundle is still read, best effort, with no version-specific checks. + BundleVersionNotUnderstood Text deriving stock (Generic, Eq, Show) --- | A concept whose timestamp appears newer than its nearest covering log. +-- | What a bundle's declared version implies for validation. +-- +-- This is the one place in okf that answers that question. Every OKF v0.1 +-- compatibility tolerance is applied unconditionally where it is read — that is +-- the policy of @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ — and a +-- family that wants to know whether the bundle has opted into a later version's +-- rules asks 'gateDeclaresAtLeast' here rather than testing the declaration +-- itself. Scattering version tests is what this type exists to prevent. +data VersionGate = VersionGate + { gateDeclaration :: !VersionDeclaration, + -- | The version okf reads the bundle as, after §12's best-effort rules. + -- 'Nothing' means no version-specific rule applies. + gateEffective :: !(Maybe OkfVersion), + -- | The declared version okf could not make sense of, if any. + gateNotUnderstood :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | Apply specification §12's rules for reading a declared version. +-- +-- §12 defines a minor bump as backward-compatible additions and a major bump as +-- possibly breaking, and asks consumers that do not understand a declared +-- version to "attempt best-effort consumption rather than refusing the bundle". +-- Three cases follow: +-- +-- * A version okf understands is read as itself. +-- +-- * A known major with a higher minor — @0.3@ today — is read as the highest +-- version okf understands within that major. The additions okf has never +-- heard of are, by §12's definition of a minor bump, additions it can ignore. +-- +-- * An unknown major — @1.0@ — is read with no version-specific rules at all, +-- and reported once under 'StrictAuthoring'. §12 permits a major bump to +-- rename required fields and change reserved filenames, so okf genuinely +-- cannot know which of its rules still hold. +-- +-- An absent or unparseable declaration also applies no version-specific rules. +-- An undeclared bundle is precisely the case the unconditional v0.1 fallbacks +-- exist to serve, and it is the shape of almost every bundle in existence. +versionGate :: VersionDeclaration -> VersionGate +versionGate declaration = + case declaration of + VersionDeclared version + | okfVersionMajor version == okfVersionMajor supportedOkfVersion -> + understood (Just (min version supportedOkfVersion)) + | otherwise -> + VersionGate + { gateDeclaration = declaration, + gateEffective = Nothing, + gateNotUnderstood = Just (renderOkfVersion version) + } + VersionUndeclared -> understood Nothing + VersionUnparseable _ -> understood Nothing + where + understood effective = + VersionGate + { gateDeclaration = declaration, + gateEffective = effective, + gateNotUnderstood = Nothing + } + +-- | Whether the bundle has declared itself to target at least the given +-- version. This is how a check asks "may I hold this bundle to my rules?"; a +-- future v0.3 family asks the same question with a different argument. +gateDeclaresAtLeast :: OkfVersion -> VersionGate -> Bool +gateDeclaresAtLeast minimumVersion VersionGate {gateEffective} = + maybe False (>= minimumVersion) gateEffective + +-- | A concept whose generated date appears newer than its nearest covering log. data LogStaleness = LogStaleness { staleConcept :: !ConceptId, staleConceptDate :: !Text, @@ -62,18 +254,160 @@ -- | Validate a whole bundle: per-document checks under the given profile, plus -- referential integrity (no links to missing concepts) and uniqueness of -- concept IDs. An empty list means the bundle is valid under the profile. -validateBundle :: ValidationProfile -> [Concept] -> [BundleValidationError] -validateBundle profile concepts = - perDocument <> dangling <> duplicates +-- +-- The 'VersionDeclaration' is what the bundle root's @index.md@ says about the +-- version it targets, read with 'Okf.Index.readBundleVersion'. Pass +-- 'VersionUndeclared' for a bundle whose declaration is unknown or irrelevant: +-- that is the reading almost every bundle gets, and it applies no +-- version-specific rules. Everything the declaration implies is decided by +-- 'versionGate'. +-- +-- The 'BundleInventory' is every file the bundle holds, read with +-- 'Okf.Bundle.walkBundleInventory'. It is what lets a path-valued frontmatter +-- field be resolved against a target that is not a concept — a @references\/@ +-- script, a CSV — without giving validation a filesystem handle. A caller with +-- no directory to walk passes 'Okf.Bundle.bundleInventoryOfConcepts', which +-- reports the concepts' own paths and nothing else. +validateBundle :: ValidationProfile -> VersionDeclaration -> BundleInventory -> [Concept] -> [BundleValidationError] +validateBundle profile declaration inventory concepts = + perDocument <> dangling <> frontmatterPaths <> duplicates <> versionErrors where + gate = versionGate declaration + frontmatterPaths = case profile of + PermissiveConformance -> [] + StrictAuthoring -> danglingFrontmatterPaths inventory concepts perDocument = [ DocumentInvalid (conceptIdOf concept) err | concept <- concepts, - err <- validateDocument profile (conceptDocument concept) + err <- + validateDocument profile (conceptDocument concept) + <> legacyFieldsUnderDeclaredVersion profile gate (conceptDocument concept) ] dangling = uncurry DanglingReference <$> danglingReferences concepts duplicates = DuplicateConceptId <$> duplicateConceptIds concepts + versionErrors = case profile of + PermissiveConformance -> [] + StrictAuthoring -> + [BundleVersionUnparseable rawVersion | VersionUnparseable rawVersion <- [declaration]] + <> [BundleVersionNotUnderstood version | Just version <- [gateNotUnderstood gate]] +-- | Strict-mode check that a path-valued frontmatter field names a file the +-- bundle actually holds (specification §6.2). +-- +-- Strict-mode only, and deliberately not gated on the bundle declaring +-- @okf_version: "0.2"@. Every other version-sensitive check asks +-- 'gateDeclaresAtLeast' rather than testing the declaration, and this one is the +-- exception worth naming: neither @resource@ nor the §6.2 path grammar is a v0.2 +-- addition, so a dangling @resource@ is just as wrong in an undeclared bundle, +-- which is the shape of almost every bundle in existence. +-- +-- Only 'DanglingInBundle' is reported. The three other unresolved outcomes are +-- passed over on purpose, and it is not an oversight: +-- +-- * 'UnresolvableEscape' and 'UnresolvableMalformed' would fire on correct +-- documents. §4.1 defines @resource@ as "a URI that uniquely identifies the +-- underlying asset", and a producer writing a bare @analytics.tables.orders@ +-- is writing a legitimate §4.1 value that carries no scheme and so classifies +-- as a bundle path. Only the dangling case is safe to report, because it means +-- the value looks exactly like a bundle path and there is simply no such file. +-- +-- * 'ResolvedExternal' is resolved: okf has no network access and never fetches. +danglingFrontmatterPaths :: BundleInventory -> [Concept] -> [BundleValidationError] +danglingFrontmatterPaths inventory concepts = + [ DanglingFrontmatterPath + (conceptIdOf concept) + fieldName + target + (bundleRelativeAlternative existsInBundle (conceptIdOf concept) rawValue target) + | concept <- concepts, + (fieldName, rawValue) <- pathValuedFields concept, + DanglingInBundle target <- + [resolvePathReference existsInBundle (conceptIdOf concept) rawValue] + ] + where + existsInBundle = flip bundleInventoryMember inventory + +-- | For a relative value that resolved to nothing, the bundle-relative target +-- the same text /would/ have named had it been written with a leading @\/@ — +-- when that target is a file the bundle actually holds. +-- +-- Specification §10.2's worked example writes +-- @executor.resource: references\/skills\/run-on-bq.md@ and §10.4 puts +-- computations under @computations\/@, so a bundle assembled from the +-- specification's own text names @computations\/references\/skills\/run-on-bq.md@ +-- and is told about a path nobody wrote. §6.2 defines exactly three forms and +-- resolution is unchanged; this only lets the diagnostic name the spelling that +-- works. +-- +-- Silent in three cases, each on purpose. A value already written with a leading +-- @\/@ was read from the bundle root already, so there is no alternative reading +-- to offer. A concept at the bundle root resolves both readings to the same path, +-- so the hint would suggest exactly what was just rejected. And a root-anchored +-- reading that also names nothing is no more use to the author than the original. +bundleRelativeAlternative :: (FilePath -> Bool) -> ConceptId -> Text -> FilePath -> Maybe FilePath +bundleRelativeAlternative exists sourceConcept rawValue target + | "/" `Text.isPrefixOf` Text.strip rawValue = Nothing + | otherwise = case resolvePathReference exists sourceConcept ("/" <> Text.strip rawValue) of + ResolvedInBundle alternative | alternative /= target -> Just alternative + _ -> Nothing + +-- | The path-valued frontmatter fields okf resolves without being asked, paired +-- with the field name a diagnostic names so the author knows which line to fix. +-- +-- Specification §6.2 names five path-valued fields. Two of them are absent here +-- for different reasons, and both are decisions rather than gaps. +-- +-- @sources[].resource@ is excluded because §5.1 sanctions a value that is not a +-- path: an entry's resource names "either a concrete artifact a consumer can +-- follow ... or a population or scope descriptor it cannot", and +-- 'Okf.Document.sourceResource' says in as many words never to treat it as one. +-- @examples\/ddd-ordering@ carries such a descriptor today, and a check +-- reporting every unresolvable bundle path would report that correct bundle as +-- broken. A team whose corpus does use followable paths there opts in by writing +-- a profile: @path@ on a @NestedFieldRule@ reaches @sources.resource@ already. +-- +-- @computation@, @executor.resource@, and @attester.resource@ are here, and +-- unlike @sources[].resource@ nothing in §10 sanctions a non-path value for +-- them: §10.2 defines @computation@ as "a path (§6.2) to a file holding the +-- computation" and both @resource@ members as naming code or run instructions "a +-- runner ... follows", which a scope descriptor is not. Their whole purpose is +-- to be followed, and §6.3 puts the files they name inside the bundle under +-- @references\/@, so a value naming nothing is exactly the authoring mistake +-- this check exists to catch. A target that is not Markdown — §6.3's own +-- @references\/attesters\/revenue.py@ — resolves like any other, because the +-- 'BundleInventory' records every file rather than only the concepts. +-- +-- The nested field names are written with a dot, as @executor.resource@, so the +-- diagnostic names the line an author must fix rather than the mapping holding +-- it. +pathValuedFields :: Concept -> [(Text, Text)] +pathValuedFields concept = + [("resource", value) | Just value <- [conceptResource concept]] + <> [("computation", value) | Just value <- [conceptComputation concept]] + <> [("executor.resource", value) | Just executor <- [conceptExecutor concept], Just value <- [executorResource executor]] + <> [("attester.resource", value) | Just attester <- [conceptAttester concept], Just value <- [attesterResource attester]] + +-- | Strict-mode check that a bundle which has declared OKF v0.2 carries no +-- superseded v0.1 construct. +-- +-- okf reads a v0.1 @timestamp@ whenever @generated@ is absent, always and +-- silently; @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ fixes that as the +-- policy and this check does not change it. What it adds is the other half of +-- the answer that ADR left open. A bundle that has explicitly said +-- @okf_version: "0.2"@ and still carries @timestamp@ is not exercising a +-- compatibility path; it is describing a document nobody finished migrating, +-- and only the declaration makes that distinction possible. +-- +-- Strict-mode only, and silent for an undeclared bundle. +legacyFieldsUnderDeclaredVersion :: ValidationProfile -> VersionGate -> OKFDocument -> [ValidationError] +legacyFieldsUnderDeclaredVersion PermissiveConformance _ _ = [] +legacyFieldsUnderDeclaredVersion StrictAuthoring gate OKFDocument {frontmatter} + | not (gateDeclaresAtLeast (OkfVersion {okfVersionMajor = 0, okfVersionMinor = 2}) gate) = [] + | isJust (frontmatterLookup "timestamp" frontmatter), + isNothing (frontmatterLookup "generated" frontmatter) = + [LegacyFieldInDeclaredV2 "timestamp"] + | otherwise = [] + -- | Validate all parsed @log.md@ files discovered in a bundle. validateBundleLogs :: [LogFile] -> [BundleValidationError] validateBundleLogs = validateLogs @@ -86,12 +420,12 @@ err <- validateLog (logContent logFile) ] --- | Find concepts whose timestamp date is newer than their nearest enclosing log. +-- | Find concepts whose generated date is newer than their nearest enclosing log. logStaleness :: [Concept] -> [LogFile] -> [LogStaleness] logStaleness concepts logs = [ staleness | concept <- concepts, - Just conceptDate <- [conceptTimestampDate concept], + Just conceptDate <- [conceptGeneratedDate concept], let nearest = nearestEnclosingLog (conceptSourcePath concept) logs, Just staleness <- [staleIfNeeded concept conceptDate nearest] ] @@ -104,8 +438,194 @@ <> case profile of PermissiveConformance -> [] StrictAuthoring -> - foldMap (requireNonEmptyText MissingRecommendedField `flip` document) ["title", "description", "timestamp"] + foldMap (requireNonEmptyText MissingRecommendedField `flip` document) ["title", "description"] + <> requireGenerated document + <> checkSources document + <> checkFootnoteAttribution document + <> requireComputationRuntime document + <> requireOneComputation document +-- | Strict-mode check on the OKF v0.2 attested computation contract +-- (specification §10.2). +-- +-- Fires only on a concept whose @type@ is exactly +-- 'Okf.Document.attestedComputationType', and reports only the one field §10.2 +-- marks REQUIRED. Everything else the contract can get wrong — a @parameters@ +-- entry with no @type@, an @executor@ with no @resource@, an @attester@ naming a +-- file nobody wrote — is a house convention a profile already expresses, with +-- @objectFields@ reaching inside @executor@ and a @TypeRule@ scoping it to this +-- type. Adding those here would be inventing a taxonomy the specification +-- declines to fix, which is the mistake +-- @docs\/plans\/47-enforce-the-profile-declared-okfversion-and-ship-a-v0-2-reference-profile.md@ +-- made and withdrew. +-- +-- A whitespace-only @runtime@ counts as absent: it names no runtime, and §10.2's +-- whole point is that the value is what gives @parameters@ their meaning. +requireComputationRuntime :: OKFDocument -> [ValidationError] +requireComputationRuntime OKFDocument {frontmatter} + | frontmatterLookup "type" frontmatter /= Just (String attestedComputationType) = [] + | maybe True (Text.null . Text.strip) (readRuntime frontmatter) = + [AttestedComputationMissingRuntime] + | otherwise = [] + +-- | Strict-mode check on specification §10.3's exactly-one rule. +-- +-- §10.3 provides the computation "in one of two ways" — inline, as a code block +-- in the body under @# Computation@, or by file, by setting @computation@ to a +-- path and omitting the body block. Neither and both are equally wrong, and so +-- is one @# Computation@ section holding two blocks. +-- +-- Fires only on a concept whose @type@ is exactly +-- 'Okf.Document.attestedComputationType', like every other check on this +-- contract. Strict-only for the reason +-- @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ gives: §11's conformance +-- list does not reach a computation field, and §11 separately forbids rejecting +-- a bundle over an unknown @type@ value, so "the format requires this" binds the +-- producer rather than licensing a consumer to refuse. +-- +-- At most one diagnostic per document, ambiguity first. A document with a +-- @computation@ key and two body blocks has one thing to fix, not two, and the +-- ambiguity is the more serious half. +requireOneComputation :: OKFDocument -> [ValidationError] +requireOneComputation document@OKFDocument {frontmatter} + | frontmatterLookup "type" frontmatter /= Just (String attestedComputationType) = [] + | not (null files) && not (null inlines) = [AttestedComputationHasBothComputations] + | length inlines > 1 = [AttestedComputationHasManyBlocks (length inlines)] + | null files && null inlines = [AttestedComputationHasNoComputation] + | otherwise = [] + where + (files, inlines) = List.partition isFile (readComputationSources document) + isFile = \case + ComputationFile _ -> True + ComputationInline _ -> False + +-- | Strict-mode checks on the OKF v0.2 @sources@ family (specification §5.1). +-- +-- Both diagnostics fire only when @sources@ is present, and only under +-- 'StrictAuthoring': §11 forbids rejecting a bundle for a missing optional +-- family, and @sources@ is optional. +-- +-- Note this inspects the __raw YAML list__ rather than 'readSources' output. +-- 'readSources' has already dropped entries without a @resource@, so the parsed +-- list cannot report them, and an index into it would not match the index a +-- person sees in the file. +-- +-- No check resolves a @resource@ or reports it as dangling. §5.1 permits a +-- resource to name "a population or scope descriptor" a consumer cannot follow, +-- such as @all queries in BigQuery project X@. +checkSources :: OKFDocument -> [ValidationError] +checkSources OKFDocument {frontmatter} = + case frontmatterLookup "sources" frontmatter of + Just (Array entries) -> missingResource entries <> duplicateIds entries + _ -> [] + where + missingResource entries = + [ SourceMissingResource entryIndex + | (entryIndex, Object entryFields) <- zip [0 ..] (Vector.toList entries), + isNothing (entryTextField "resource" entryFields) + ] + -- Scoped to one document. §5.1 does not require ids to be unique across a + -- bundle, only that a label unambiguously names one entry where it is used. + duplicateIds entries = + DuplicateSourceId + <$> appearingMoreThanOnce + [ entryId + | Object entryFields <- Vector.toList entries, + Just entryId <- [entryTextField "id" entryFields] + ] + entryTextField key entryFields = + case KeyMap.lookup (AesonKey.fromText key) entryFields of + Just (String value) | not (Text.null (Text.strip value)) -> Just value + _ -> Nothing + appearingMoreThanOnce values = + List.nub [value | (value, count) <- countOccurrences values, count > (1 :: Int)] + countOccurrences values = + [(value, length (filter (== value) values)) | value <- List.nub values] + +-- | Strict-mode checks joining the body's footnote labels to @sources@ entry +-- ids (specification §5.1's per-claim attribution). +-- +-- §5.1: "The footnote label is the join key into @sources@; consumers resolve +-- attribution through the matching entry, not by parsing the footnote prose." +-- Labels are keyed rather than positional because agents rewrite these documents +-- constantly and a positional index misattributes silently the moment the list +-- is reordered. The join is therefore worth checking in both directions, at two +-- different severities. +-- +-- Each direction is gated on the other side having opted into per-claim +-- attribution, and the two gates are the same rule seen from opposite ends. +-- +-- Labels are checked only when the document has a @sources@ key. Markdown +-- footnotes are legal prose used for ordinary purposes, and a document that has +-- not opted into structured provenance is making no attribution claim; +-- reporting every footnote in such a body would make the check hostile. +-- +-- Ids are checked only when the body cites at least one footnote label. §5.1 +-- asks for an @id@ "when the body cites the source", so an id in a body that +-- cites nothing is simply not being used for per-claim attribution — the same +-- reason an entry with no @id@ at all is never reported. Without this gate every +-- @sources@ document that uses no footnotes, which is the common shape, would +-- emit one lint per entry. +-- +-- The join is document-local, matching §5.1. Ids are not required to be unique +-- across a bundle, so a label naming an id in some other document means nothing. +-- Within one document 'DuplicateSourceId' already guarantees "the matching +-- entry" is well defined. +-- +-- Both diagnostics are strict-mode only, per §11's rule that a consumer must not +-- reject a bundle over optional frontmatter. +checkFootnoteAttribution :: OKFDocument -> [ValidationError] +checkFootnoteAttribution OKFDocument {frontmatter, body} = + case frontmatterLookup "sources" frontmatter of + Nothing -> [] + Just sourcesValue -> + let entryIds = sourceIdsOf sourcesValue + labels = footnoteLabelsUsed (extractFootnoteLabels body) + in [FootnoteLabelNotInSources label | label <- labels, label `notElem` entryIds] + <> [ SourceIdNotCited entryId + | not (null labels), + entryId <- entryIds, + entryId `notElem` labels + ] + where + -- Read ids from the raw YAML list rather than 'readSources', for the same + -- reason 'checkSources' does: 'readSources' drops entries with no + -- @resource@, and an id the author wrote should still join even when the + -- entry holding it is separately malformed. + sourceIdsOf = \case + Array entries -> + List.nub + [ entryId + | Object entryFields <- Vector.toList entries, + Just (String rawId) <- [KeyMap.lookup (AesonKey.fromText "id") entryFields], + let entryId = Text.strip rawId, + not (Text.null entryId) + ] + _ -> [] + +-- | Strict-mode check for the OKF v0.2 @generated@ family (specification §5.2). +-- +-- A document satisfies "when was this last changed" with either @generated@ +-- carrying a @by@ actor or, falling back per §13.1, a non-empty legacy v0.1 +-- @timestamp@. Reading the legacy key is deliberately silent: a warning on +-- every v0.1 document would make the tool unusable against existing bundles. +-- See @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@. +-- +-- Both diagnostics are strict-mode only. Specification §11 forbids rejecting a +-- bundle for a missing optional frontmatter field, and @generated@ is optional. +requireGenerated :: OKFDocument -> [ValidationError] +requireGenerated document@OKFDocument {frontmatter} = + case frontmatterLookup "generated" frontmatter of + Nothing + | hasLegacyTimestamp -> [] + | otherwise -> [MissingGeneratedField] + Just _ + | isJust (readGenerated frontmatter) -> [] + | otherwise -> [GeneratedMustHaveActor] + where + hasLegacyTimestamp = + null (requireNonEmptyText MissingRecommendedField "timestamp" document) + requireNonEmptyText :: (Text -> ValidationError) -> Text -> OKFDocument -> [ValidationError] requireNonEmptyText missing key OKFDocument {frontmatter} = case frontmatterLookup key frontmatter of @@ -127,12 +647,25 @@ isString (String _) = True isString _ = False -conceptTimestampDate :: Concept -> Maybe Text -conceptTimestampDate concept = - case frontmatterLookup "timestamp" (frontmatter (conceptDocument concept)) of - Just (String timestamp) - | Text.length timestamp >= 10 -> Just (Text.take 10 timestamp) - _ -> Nothing +-- | The @YYYY-MM-DD@ date a concept's content last changed, read from the OKF +-- v0.2 @generated.at@ (specification §5.2) in preference to the legacy v0.1 +-- @timestamp@ it supersedes (§13.1). When both are present @generated.at@ wins. +-- +-- An ISO 8601 datetime carries the date in its first ten characters, so +-- anything shorter is not a usable date and yields 'Nothing'. +conceptGeneratedDate :: Concept -> Maybe Text +conceptGeneratedDate concept = + datePrefix (generatedAt =<< readGenerated conceptFrontmatter) + <|> datePrefix (legacyTimestamp conceptFrontmatter) + where + conceptFrontmatter = frontmatter (conceptDocument concept) + legacyTimestamp frontmatterValue = + case frontmatterLookup "timestamp" frontmatterValue of + Just (String timestamp) -> Just timestamp + _ -> Nothing + datePrefix = \case + Just value | Text.length value >= 10 -> Just (Text.take 10 value) + _ -> Nothing staleIfNeeded :: Concept -> Text -> Maybe LogFile -> Maybe LogStaleness staleIfNeeded concept conceptDate nearest = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,2982 +5,6275 @@ import Data.Aeson (object, toJSON, (.=)) import Data.Foldable (for_, toList) import Data.List qualified as List -import Data.Text qualified as Text -import Data.Text.IO qualified as Text.IO -import Okf.Bundle -import Okf.ConceptId -import Okf.Discovery -import Okf.Document -import Okf.Graph -import Okf.Index -import Okf.Log -import Okf.Prelude hiding (List, setField, (.=)) -import Okf.Profile -import Okf.Profile.Registry -import Okf.Validation -import System.Directory - ( createDirectoryIfMissing, - doesDirectoryExist, - doesFileExist, - getTemporaryDirectory, - removeDirectoryRecursive, - ) -import System.Exit (exitFailure) -import System.FilePath (normalise, takeDirectory, ()) -import System.IO.Temp (createTempDirectory) -import "generic-lens" Data.Generics.Labels () - -main :: IO () -main = do - results <- - sequence - [ test "parse valid document with YAML frontmatter" testParseValidDocument, - test "parse document with no frontmatter as empty-frontmatter body" testParseNoFrontmatter, - test "reject unterminated frontmatter" testRejectUnterminatedFrontmatter, - test "reject frontmatter that is not a YAML mapping" testRejectNonMappingFrontmatter, - test "validate permissive profile with only type" testPermissiveValidation, - test "validate strict profile requiring title description timestamp" testStrictValidation, - test "validate rejects tags that are not a string list" testRejectInvalidTags, - test "round-trip preserves semantic frontmatter and body" testRoundTrip, - test "reject invalid concept id segment" testRejectInvalidConceptId, - test "convert concept id tables/users to tables/users.md" testConceptIdToFilePath, - testIO "walkBundle reports a structured IO error for a missing root" testWalkBundleMissingRoot, - testIO "walkBundle skips index.md and log.md" testWalkBundleSkipsReserved, - testIO "walkBundle discovers nested concept IDs" testWalkBundleDiscoversNestedConceptIds, - testIO "discoverBundleRoots finds a directory holding index.md" testDiscoverIndexMd, - testIO "discoverBundleRoots finds a directory holding a typed concept" testDiscoverTypedConcept, - testIO "discoverBundleRoots ignores markdown without a type field" testDiscoverIgnoresPlainMarkdown, - testIO "discoverBundleRoots does not descend into a bundle it found" testDiscoverPrunesNestedBundles, - testIO "discoverBundleRoots skips hidden and build directories" testDiscoverSkipsNoise, - testIO "discoverBundleRoots honours maxDepth" testDiscoverHonoursMaxDepth, - testIO "discoverBundleRoots reports a fixture bundle as its own root" testDiscoverFixtureBundle, - test "parseLog/serializeLog round-trips a canonical log" testLogRoundTrip, - test "validateLog flags a non-ISO date heading" testValidateLogNonIsoDate, - test "validateLog flags an empty date group" testValidateLogEmptyDay, - test "validateLog flags out-of-order days" testValidateLogOutOfOrder, - testIO "walkLogs discovers nested log.md files" testWalkLogsDiscoversNested, - test "logStaleness flags a concept newer than its nearest log" testLogStalenessFlagsNewerConcept, - test "logStaleness prefers the deepest enclosing log" testLogStalenessPrefersDeepestLog, - test "appendLogEntry inserts newest-first and prepends within a day" testAppendLogEntry, - testIO "generateIndex groups documents by frontmatter type" testGenerateIndexGroupsByType, - testIO "extractLinks resolves relative and absolute bundle links" testExtractLinksResolveBundleLinks, - testIO "extractLinks ignores external markdown URLs" testExtractLinksIgnoresExternalUrls, - testIO "buildGraph includes only edges to existing concepts" testBuildGraphIncludesKnownEdges, - testIO "writeBundleIndexes is deterministic" testWriteBundleIndexesDeterministic, - testIO "fixture valid bundle validates and graphs expected edges" testFixtureValidBundle, - testIO "fixture graph JSON shape is stable" testFixtureGraphJsonShape, - testIO "fixture unterminated frontmatter reports parse error" testFixtureUnterminatedFrontmatter, - testIO "fixture missing type reports validation error" testFixtureMissingType, - test "frontmatter builder round-trips through serialize and parse" testFrontmatterBuilderRoundTrip, - test "serializeDocument emits deterministic key order" testSerializeDeterministicKeyOrder, - test "rendered concept link round-trips through extractConceptLinks" testConceptLinkRoundTrip, - test "over-escaping relative links do not resolve inside bundle" testRejectOverEscapingRelativeLink, - test "validateBundle reports a dangling reference" testValidateBundleDanglingReference, - test "validateBundle accepts a bundle whose links all resolve" testValidateBundleAcceptsResolved, - test "duplicateConceptIds finds repeated ids" testDuplicateConceptIds, - test "conceptFromDocument derives typed fields from frontmatter" testConceptFromDocumentDerivesFields, - testIO "writeBundle then walkBundle round-trips" testWriteBundleRoundTrip, - testIO "fixture dangling link reports a bundle validation error" testFixtureDanglingLink, - testIO "loadProfileFile decodes the postgresql fixture" testLoadProfileFixture, - testIO "loadProfileFile decodes record-completed document ID rules" testLoadDocumentIdProfileFixture, - testIO "loadProfileFile accepts the pre-type-frontmatter described schema" testLoadDescribedProfileFixture, - testIO "loadProfileFile accepts the frozen EP-1 type-aware schema" testLoadTypeAwareCompatibilityFixture, - testIO "loadProfileFile accepts the frozen EP-2 vocabulary schema" testLoadVocabularyCompatibilityFixture, - testIO "loadProfileFile accepts the frozen EP-3 cardinality schema" testLoadCardinalityCompatibilityFixture, - testIO "loadProfileFile accepts the frozen EP-4 format schema" testLoadFormatCompatibilityFixture, - testIO "loadProfileFile decodes bounded nested review rules" testLoadNestedReviewsProfileFixture, - testIO "loadProfileFile preserves the frozen bounded-nested schema" testLoadNestedCompatibilityFixture, - testIO "loadProfileFile decodes same-scope conditions" testLoadConditionalFieldsProfileFixture, - testIO "loadProfileFile preserves the frozen condition-aware schema" testLoadConditionalCompatibilityFixture, - testIO "loadProfileFile preserves the frozen reference-aware schema" testLoadReferenceCompatibilityFixture, - testIO "loadProfileFile still accepts an okf 0.2.x descriptor" testLoadLegacyProfileFixture, - testIO "profileFieldDescription finds required and recommended prose" testProfileFieldDescription, - testIO "profileFieldDescription finds optional prose" testOptionalFieldDescription, - testIO "profile JSON encoding emits type, not type_" testProfileJsonShape, - test "field condition JSON encoding is stable" testFieldConditionJsonShape, - test "handle reference JSON encoding is stable" testHandleReferenceJsonShape, - test "field format JSON encoding is stable" testFieldFormatJsonShape, - testIO "loadRegistry enumerates nested profiles and skips non-profiles" testRegistryEnumeratesProfiles, - testIO "loadRegistry reports a bare profile as a root entry" testRegistryRootProfile, - testIO "resolveRegistryRef prefers package.dhall inside a directory" testResolveRegistryRef, - testIO "loadRegistry reports a missing registry as Left" testRegistryLoadFailure, - test "parseDocumentId accepts only canonical handles" testParseDocumentId, - testIO "documentIdsInBundle sorts handles by prefix and number" testDocumentIdsInBundle, - test "nextDocumentId skips gaps and starts unused prefixes at one" testNextDocumentId, - testIO "findConceptsByDocumentId resolves and reports duplicate handles" testFindConceptsByDocumentId, - test "compileProfile rejects ambiguous definitions deterministically" testCompileProfileDefinitionErrors, - test "compiled rules merge profile and type requirements" testCompiledProfileMerge, - test "compiled vocabularies intersect in profile declaration order" testCompiledVocabularyIntersection, - test "compileProfile rejects disjoint vocabularies" testUnsatisfiableVocabulary, - test "compiled cardinality uses Any as identity and rejects contradictions" testCompiledCardinality, - test "profile vocabularies validate strings, lists, and shapes" testVocabularyValidation, - test "profile cardinality validates all JSON shapes and presence" testCardinalityValidation, - test "cardinality suppresses redundant vocabulary shape errors" testCardinalityVocabularyInteraction, - test "compiled formats refine Uri and reject contradictions" testCompiledFieldFormats, - test "compileProfile rejects invalid format parameters" testInvalidFormatParameters, - test "named formats validate parser boundaries, lists, and shapes" testNamedFormatValidation, - test "compiled nested rules merge and reject impossible outer cardinality" testCompiledNestedRules, - test "nested record validation reports indexed paths and strict recommendations" testNestedRecordValidation, - test "compileProfile rejects invalid same-scope field conditions" testConditionDefinitionErrors, - test "top-level conditions gate presence without gating value checks" testTopLevelConditionalPresence, - test "nested conditions use siblings and avoid cascading diagnostics" testNestedConditionalPresence, - test "compileProfile rejects invalid document reference policies" testReferenceDefinitionErrors, - test "document references resolve local handles and explicit external URIs" testDocumentReferenceValidation, - test "optional fields are never missing but are fully value-checked" testOptionalFieldPresence, - test "optional reference fields resolve handles when present" testOptionalReferenceValidation, - test "optional nested fields are never missing inside records" testOptionalNestedFieldPresence, - test "optional fields count as declared under closed field names" testOptionalFieldClosure, - test "optional at one scope does not cancel the other scope's clause" testOptionalDoesNotCancelOtherScope, - test "compileProfile rejects optional collisions and dead conditions" testOptionalDefinitionErrors, - test "closed profiles reject unknown fields and isolate type fields" testClosedFieldValidation, - test "profile rules apply to unknown concept types" testProfileRulesApplyToUnknownTypes, - test "strict profile validation checks recommendations" testStrictProfileRecommendations, - test "validateProfile accepts a conforming table concept" testProfileConformingTable, - test "validateProfile flags a type not in the vocabulary" testProfileUnknownType, - test "validateProfile flags a missing required field" testProfileMissingField, - test "validateProfile flags a resource scheme mismatch" testProfileResourceMismatch, - test "validateProfile flags a path pattern mismatch" testProfilePathMismatch, - test "validateProfile flags a missing # Schema section" testProfileMissingSchema, - test "validateProfile flags mismatched # Schema columns" testProfileSchemaColumnsMismatch, - test "validateProfile accepts a conforming document ID" testProfileConformingDocumentId, - test "validateProfile flags a missing document ID" testProfileMissingDocumentId, - test "validateProfile flags malformed document IDs" testProfileMalformedDocumentIds, - test "validateProfile flags duplicate document IDs" testProfileDuplicateDocumentIds, - test "validateProfile document ID checks are off by default" testProfileDocumentIdsOffByDefault, - test "schemaSectionColumns reads the header row of the Schema table" testSchemaSectionColumns, - testIO "validateProfile reports the expected deviations for the fixture bundle" testProfileDeviationsFixture, - testIO "validateProfile reports document ID fixture deviations" testDocumentIdDeviationsFixture, - testIO "type-aware fixture is permissive but reports one strict recommendation" testTypeAwareProfileFixture, - testIO "closed-field fixture reports missing and misspelled fields" testClosedFieldsFixture, - testIO "cardinality fixture reports scalar and list mismatches" testCardinalityFixture, - testIO "format fixture reports parser-backed mismatches" testFormatsFixture, - testIO "nested review fixture validates records with indexed diagnostics" testNestedReviewsFixture, - testIO "conditional fixture covers ADR, PostgreSQL, and review scopes" testConditionalFieldsFixture, - testIO "document reference fixture covers local, external, self, and duplicate targets" testDocumentReferencesFixture, - testIO "optional-field fixture reports only the recommendation and bad values" testOptionalFieldsFixture - ] - unless (and results) exitFailure - -test :: Text -> Either Text () -> IO Bool -test name assertion = - case assertion of - Right () -> do - putStrLn ("PASS " <> Text.unpack name) - pure True - Left message -> do - putStrLn ("FAIL " <> Text.unpack name <> ": " <> Text.unpack message) - pure False - -testIO :: Text -> IO (Either Text ()) -> IO Bool -testIO name assertion = do - result <- assertion - test name result - -testParseValidDocument :: Either Text () -testParseValidDocument = do - document <- firstShow (parseDocument sampleDocument) - assertEqual (Just (String "BigQuery Table")) (frontmatterLookup "type" (document ^. #frontmatter)) - assertEqual "# Schema\n\nBody text.\n" (body document) - -testParseNoFrontmatter :: Either Text () -testParseNoFrontmatter = do - document <- firstShow (parseDocument "# Draft\n") - assertEqual Nothing (frontmatterLookup "type" (document ^. #frontmatter)) - assertEqual "# Draft\n" (body document) - -testRejectUnterminatedFrontmatter :: Either Text () -testRejectUnterminatedFrontmatter = - assertEqual (Left UnterminatedFrontmatter) (parseDocument "---\ntype: BigQuery Table\n") - -testRejectNonMappingFrontmatter :: Either Text () -testRejectNonMappingFrontmatter = - assertEqual (Left FrontmatterNotMapping) (parseDocument "---\n- one\n- two\n---\nBody\n") - -testPermissiveValidation :: Either Text () -testPermissiveValidation = do - document <- firstShow (parseDocument "---\ntype: BigQuery Table\n---\nBody\n") - assertEqual [] (validateDocument PermissiveConformance document) - -testStrictValidation :: Either Text () -testStrictValidation = do - document <- firstShow (parseDocument "---\ntype: BigQuery Table\n---\nBody\n") - let errors = validateDocument StrictAuthoring document - assertBool "missing title" (MissingRecommendedField "title" `List.elem` errors) - assertBool "missing description" (MissingRecommendedField "description" `List.elem` errors) - assertBool "missing timestamp" (MissingRecommendedField "timestamp" `List.elem` errors) - -testRejectInvalidTags :: Either Text () -testRejectInvalidTags = do - document <- firstShow (parseDocument "---\ntype: BigQuery Table\ntags: orders\n---\nBody\n") - assertEqual [FieldMustBeListOfText "tags"] (validateDocument PermissiveConformance document) - -testRoundTrip :: Either Text () -testRoundTrip = do - document <- firstShow (parseDocument sampleDocument) - assertEqual [] (validateDocument PermissiveConformance document) - assertEqual [] (validateDocument StrictAuthoring document) - reparsed <- firstShow (parseDocument (serializeDocument document)) - assertEqual (document ^. #frontmatter) (reparsed ^. #frontmatter) - assertEqual (body document) (body reparsed) - -testRejectInvalidConceptId :: Either Text () -testRejectInvalidConceptId = - assertEqual (Left (InvalidConceptIdSegment "-users")) (parseConceptId "tables/-users") - -testConceptIdToFilePath :: Either Text () -testConceptIdToFilePath = do - conceptId <- firstShow (parseConceptId "tables/users") - assertEqual "tables/users.md" (conceptIdToFilePath conceptId) - -testWalkBundleMissingRoot :: IO (Either Text ()) -testWalkBundleMissingRoot = do - temporaryDirectory <- getTemporaryDirectory - root <- createTempDirectory temporaryDirectory "okf-core-missing-parent" - let missingRoot = root "missing" - result <- walkBundle missingRoot - removeDirectoryRecursive root - pure - ( case result of - Left (BundleIoError path message) - | path == missingRoot && "does not exist" `Text.isInfixOf` message -> Right () - other -> Left ("expected missing-root BundleIoError, got " <> Text.pack (show other)) - ) - -testWalkBundleSkipsReserved :: IO (Either Text ()) -testWalkBundleSkipsReserved = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure (assertEqual ["datasets/sales", "tables/customers", "tables/orders"] (renderConceptId . conceptIdOf <$> concepts)) - ) - -testWalkBundleDiscoversNestedConceptIds :: IO (Either Text ()) -testWalkBundleDiscoversNestedConceptIds = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure - ( do - expected <- firstShow (parseConceptId "tables/orders") - assertBool "nested concept exists" (isJust (findConcept expected concepts)) - ) - ) - --- | Build a throwaway directory tree, run an action on it, and clean up. -withDiscoveryTree :: String -> [(FilePath, Text)] -> (FilePath -> IO a) -> IO a -withDiscoveryTree label files action = do - temporaryDirectory <- getTemporaryDirectory - root <- createTempDirectory temporaryDirectory label - for_ files $ \(relativePath, content) -> do - createDirectoryIfMissing True (root takeDirectory relativePath) - Text.IO.writeFile (root relativePath) content - result <- action root - removeDirectoryRecursive root - pure result - -typedConcept :: Text -> Text -typedConcept titleText = - Text.unlines ["---", "type: Table", "title: " <> titleText, "---", "", "# " <> titleText] - -plainMarkdown :: Text -plainMarkdown = "# Just prose\n\nNo frontmatter here.\n" - -testDiscoverIndexMd :: IO (Either Text ()) -testDiscoverIndexMd = - withDiscoveryTree "okf-discovery-index" [("kb/index.md", "# Index\n")] $ \root -> do - found <- discoverBundleRoots defaultDiscoveryOptions root - pure (assertEqual [normalise (root "kb")] found) - -testDiscoverTypedConcept :: IO (Either Text ()) -testDiscoverTypedConcept = - withDiscoveryTree "okf-discovery-typed" [("kb/tables/orders.md", typedConcept "Orders")] $ \root -> do - found <- discoverBundleRoots defaultDiscoveryOptions root - pure (assertEqual [normalise (root "kb" "tables")] found) - -testDiscoverIgnoresPlainMarkdown :: IO (Either Text ()) -testDiscoverIgnoresPlainMarkdown = - withDiscoveryTree - "okf-discovery-plain" - [("notes/README.md", plainMarkdown), ("notes/CHANGELOG.md", plainMarkdown)] - $ \root -> do - found <- discoverBundleRoots defaultDiscoveryOptions root - pure (assertEqual [] found) - -testDiscoverPrunesNestedBundles :: IO (Either Text ()) -testDiscoverPrunesNestedBundles = - withDiscoveryTree - "okf-discovery-prune" - [ ("kb/index.md", "# Index\n"), - ("kb/tables/index.md", "# Tables\n"), - ("kb/tables/orders.md", typedConcept "Orders") - ] - $ \root -> do - found <- discoverBundleRoots defaultDiscoveryOptions root - pure (assertEqual [normalise (root "kb")] found) - -testDiscoverSkipsNoise :: IO (Either Text ()) -testDiscoverSkipsNoise = - withDiscoveryTree - "okf-discovery-noise" - [ (".hidden/index.md", "# Hidden\n"), - ("dist-newstyle/index.md", "# Build output\n"), - ("kb/index.md", "# Index\n") - ] - $ \root -> do - found <- discoverBundleRoots defaultDiscoveryOptions root - pure (assertEqual [normalise (root "kb")] found) - -testDiscoverHonoursMaxDepth :: IO (Either Text ()) -testDiscoverHonoursMaxDepth = - withDiscoveryTree "okf-discovery-depth" [("a/b/c/index.md", "# Deep\n")] $ \root -> do - shallow <- discoverBundleRoots defaultDiscoveryOptions {maxDepth = 2} root - deep <- discoverBundleRoots defaultDiscoveryOptions {maxDepth = 3} root - pure (assertEqual [] shallow >> assertEqual [normalise (root "a" "b" "c")] deep) - -testDiscoverFixtureBundle :: IO (Either Text ()) -testDiscoverFixtureBundle = do - bundle <- fixturePath "valid-bundle" - found <- discoverBundleRoots defaultDiscoveryOptions bundle - pure (assertEqual [normalise bundle] found) - -testLogRoundTrip :: Either Text () -testLogRoundTrip = do - let canonicalLog = - Text.unlines - [ "# Directory Update Log", - "", - "## 2026-06-23", - "* **Update**: Refreshed [orders](tables/orders.md).", - "* **Creation**: Added customers.", - "", - "## 2026-06-01", - "* Deprecated a stale note." - ] - parsed = parseLog canonicalLog - reparsed = parseLog (serializeLog parsed) - assertEqual - ( Log - { logTitle = "Directory Update Log", - logDays = - [ LogDay - { logDate = "2026-06-23", - logEntries = - [ LogEntry (Just "Update") "Refreshed [orders](tables/orders.md).", - LogEntry (Just "Creation") "Added customers." - ] - }, - LogDay - { logDate = "2026-06-01", - logEntries = [LogEntry Nothing "Deprecated a stale note."] - } - ] - } - ) - parsed - assertEqual parsed reparsed - -testValidateLogNonIsoDate :: Either Text () -testValidateLogNonIsoDate = - assertBool - "expected LogDateNotIso" - (LogDateNotIso "not-a-date" `List.elem` validateLog (parseLog "# Log\n\n## not-a-date\n* **Update**: oops\n")) - -testValidateLogEmptyDay :: Either Text () -testValidateLogEmptyDay = - assertBool - "expected LogEmptyDay" - (LogEmptyDay "2026-06-23" `List.elem` validateLog (parseLog "# Log\n\n## 2026-06-23\n")) - -testValidateLogOutOfOrder :: Either Text () -testValidateLogOutOfOrder = - assertBool - "expected LogDaysOutOfOrder" - ( LogDaysOutOfOrder "2026-01-01" "2026-06-23" - `List.elem` validateLog (parseLog "# Log\n\n## 2026-01-01\n* Old.\n\n## 2026-06-23\n* New.\n") - ) - -testWalkLogsDiscoversNested :: IO (Either Text ()) -testWalkLogsDiscoversNested = do - temporaryDirectory <- getTemporaryDirectory - root <- createTempDirectory temporaryDirectory "okf-core-logs" - createDirectoryIfMissing True (root "tables") - Text.IO.writeFile (root "log.md") "# Root Log\n\n## 2026-06-23\n* Root entry.\n" - Text.IO.writeFile (root "tables" "log.md") "# Tables Log\n\n## 2026-06-22\n* Tables entry.\n" - result <- walkLogs root - removeDirectoryRecursive root - pure - ( case result of - Right logs -> assertEqual ["log.md", "tables/log.md"] (logSourcePath <$> logs) - Left bundleError -> Left ("expected logs, got " <> Text.pack (show bundleError)) - ) - -testLogStalenessFlagsNewerConcept :: Either Text () -testLogStalenessFlagsNewerConcept = do - staleId <- parseTestConceptId "stale" - staleConcept <- testConceptWithTimestamp "stale" "2026-06-23T00:00:00Z" - currentConcept <- testConceptWithTimestamp "current" "2026-01-01T00:00:00Z" - let logs = [LogFile "log.md" (parseLog "# Log\n\n## 2026-06-01\n* **Update**: logged.\n")] - assertEqual - [ LogStaleness - { staleConcept = staleId, - staleConceptDate = "2026-06-23", - staleLogPath = Just "log.md", - staleLogDate = Just "2026-06-01" - } - ] - (logStaleness [staleConcept, currentConcept] logs) - -testLogStalenessPrefersDeepestLog :: Either Text () -testLogStalenessPrefersDeepestLog = do - usersId <- parseTestConceptId "tables/users" - usersConcept <- testConceptWithTimestamp "tables/users" "2026-06-21T00:00:00Z" - let logs = - [ LogFile "log.md" (parseLog "# Root Log\n\n## 2026-06-01\n* **Update**: root.\n"), - LogFile "tables/log.md" (parseLog "# Tables Log\n\n## 2026-06-20\n* **Update**: tables.\n") - ] - assertEqual - [ LogStaleness - { staleConcept = usersId, - staleConceptDate = "2026-06-21", - staleLogPath = Just "tables/log.md", - staleLogDate = Just "2026-06-20" - } - ] - (logStaleness [usersConcept] logs) - -testAppendLogEntry :: Either Text () -testAppendLogEntry = - assertEqual - ( Log - { logTitle = "Log", - logDays = - [ LogDay "2026-06-23" [LogEntry (Just "Update") "new"], - LogDay "2026-06-01" [LogEntry (Just "Update") "prepended", LogEntry (Just "Creation") "old"] - ] - } - ) - ( appendLogEntry - "2026-06-01" - (LogEntry (Just "Update") "prepended") - ( appendLogEntry - "2026-06-23" - (LogEntry (Just "Update") "new") - (Log "Log" [LogDay "2026-06-01" [LogEntry (Just "Creation") "old"]]) - ) - ) - -testGenerateIndexGroupsByType :: IO (Either Text ()) -testGenerateIndexGroupsByType = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure - ( do - orders <- requireConcept "tables/orders" concepts - customers <- requireConcept "tables/customers" concepts - let rendered = renderIndex [] [orders, customers] - assertBool "has type heading" ("# BigQuery Table" `Text.isInfixOf` rendered) - assertBool "has orders bullet" ("[Orders](orders.md) - Order records." `Text.isInfixOf` rendered) - assertBool "has customers bullet" ("[Customers](customers.md) - Customer records." `Text.isInfixOf` rendered) - ) - ) - -testExtractLinksResolveBundleLinks :: IO (Either Text ()) -testExtractLinksResolveBundleLinks = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure - ( do - orders <- requireConcept "tables/orders" concepts - customers <- firstShow (parseConceptId "tables/customers") - sales <- firstShow (parseConceptId "datasets/sales") - let links = extractConceptLinks orders - assertBool "absolute or ./ customers link" (customers `List.elem` links) - assertBool "../ sales link" (sales `List.elem` links) - ) - ) - -testExtractLinksIgnoresExternalUrls :: IO (Either Text ()) -testExtractLinksIgnoresExternalUrls = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure - ( do - orders <- requireConcept "tables/orders" concepts - assertEqual 4 (length (extractConceptLinks orders)) - ) - ) - -testBuildGraphIncludesKnownEdges :: IO (Either Text ()) -testBuildGraphIncludesKnownEdges = - withFixtureBundle - ( \root -> do - concepts <- readBundle root - pure - ( do - orders <- firstShow (parseConceptId "tables/orders") - customers <- firstShow (parseConceptId "tables/customers") - missing <- firstShow (parseConceptId "missing") - let graph = buildGraph concepts - assertEqual 3 (length (nodes graph)) - assertBool "known edge exists" (Edge {source = orders, target = customers} `List.elem` edges graph) - assertBool "broken edge excluded" (Edge {source = orders, target = missing} `notElem` edges graph) - ) - ) - -testWriteBundleIndexesDeterministic :: IO (Either Text ()) -testWriteBundleIndexesDeterministic = - withFixtureBundle - ( \root -> do - firstResult <- writeBundleIndexes root - firstIndex <- Text.IO.readFile (root "tables" "index.md") - secondResult <- writeBundleIndexes root - secondIndex <- Text.IO.readFile (root "tables" "index.md") - pure - ( do - firstShow firstResult - firstShow secondResult - assertEqual firstIndex secondIndex - assertBool "tables index has BigQuery Table section" ("# BigQuery Table" `Text.isInfixOf` secondIndex) - ) - ) - -testFixtureValidBundle :: IO (Either Text ()) -testFixtureValidBundle = do - root <- fixturePath "valid-bundle" - concepts <- readBundle root - pure - ( do - orders <- firstShow (parseConceptId "tables/orders") - customers <- firstShow (parseConceptId "tables/customers") - sales <- firstShow (parseConceptId "datasets/sales") - assertEqual 4 (length concepts) - assertEqual [] (foldMap (validateDocument PermissiveConformance . conceptDocument) concepts) - let graph = buildGraph concepts - assertBool "orders to customers" (Edge {source = orders, target = customers} `List.elem` edges graph) - assertBool "orders to sales" (Edge {source = orders, target = sales} `List.elem` edges graph) - ) - -testFixtureGraphJsonShape :: IO (Either Text ()) -testFixtureGraphJsonShape = do - root <- fixturePath "valid-bundle" - concepts <- readBundle root - orders <- requireConceptIO "tables/orders" concepts - pure - ( case filter (\Node {id = nodeId} -> nodeId == conceptIdOf orders) (nodes (buildGraph concepts)) of - [ordersNode] -> - assertEqual - ( object - [ "id" .= ("tables/orders" :: Text), - "label" .= ("Orders" :: Text), - "type" .= ("BigQuery Table" :: Text), - "description" .= Just ("Order fact table." :: Text), - "resource" .= Just ("bigquery://analytics.tables.orders" :: Text), - "tags" .= ["orders" :: Text, "sales"] - ] - ) - (toJSON ordersNode) - other -> Left ("expected one orders node, got " <> Text.pack (show (length other))) - ) - -testFixtureUnterminatedFrontmatter :: IO (Either Text ()) -testFixtureUnterminatedFrontmatter = do - root <- fixturePath "invalid-unterminated-frontmatter" - result <- walkBundle root - pure - ( case result of - Left (InvalidConceptDocument "broken.md" UnterminatedFrontmatter) -> Right () - other -> Left ("expected unterminated frontmatter error, got " <> Text.pack (show other)) - ) - -testFixtureMissingType :: IO (Either Text ()) -testFixtureMissingType = do - root <- fixturePath "invalid-missing-type" - concepts <- readBundle root - pure - ( do - assertEqual 1 (length concepts) - case foldMap (validateDocument PermissiveConformance . conceptDocument) concepts of - [MissingRequiredField "type"] -> Right () - other -> Left ("expected missing type error, got " <> Text.pack (show other)) - ) - -testFrontmatterBuilderRoundTrip :: Either Text () -testFrontmatterBuilderRoundTrip = do - let frontmatterValue = - setField "version" (String "0.2.0") - . setTags ["orders", "sales"] - . setResource "bigquery://analytics.tables.orders" - $ okfCommon - OkfCommon - { commonType = "BigQuery Table", - commonTitle = Just "Orders", - commonDescription = Just "Order fact table.", - commonTimestamp = Just "2026-06-16T00:00:00Z" - } - original = OKFDocument frontmatterValue "# Orders\n\nBody text.\n" - reparsed <- firstShow (parseDocument (serializeDocument original)) - assertEqual (original ^. #frontmatter) (reparsed ^. #frontmatter) - assertEqual (body original) (body reparsed) - -testSerializeDeterministicKeyOrder :: Either Text () -testSerializeDeterministicKeyOrder = do - let frontmatterValue = - setField "zeta" (String "z") - . setField "alpha" (String "a") - . setTags ["t"] - . setResource "res://x" - . setType "Recipe" - . setTimestamp "2026-06-16T00:00:00Z" - . setDescription "Desc" - . setTitle "Demo" - $ emptyFrontmatter - rendered = serializeDocument (OKFDocument frontmatterValue "# Demo\n") - expectedOrder = - ["type:", "title:", "description:", "timestamp:", "resource:", "tags:", "alpha:", "zeta:"] - keyIndices <- traverse (\key -> maybe (Left ("missing key " <> key)) Right (substringIndex key rendered)) expectedOrder - assertBool ("keys not in deterministic order: " <> Text.pack (show keyIndices)) (strictlyIncreasing keyIndices) - -testConceptLinkRoundTrip :: Either Text () -testConceptLinkRoundTrip = do - sourceId <- parseTestConceptId "recipes/haskell-library-repo" - let targetStrings = ["orders", "modules/nix-haskell-flake", "refs/source-system.v1"] - mapM_ - ( \rawTarget -> do - targetId <- parseTestConceptId rawTarget - let extracted = extractFromBodyLinkingTo sourceId targetId - assertEqual [targetId] extracted - ) - targetStrings - -parseTestConceptId :: Text -> Either Text ConceptId -parseTestConceptId rawId = - first (\err -> "bad concept id " <> rawId <> ": " <> Text.pack (show err)) (parseConceptId rawId) - -extractFromBodyLinkingTo :: ConceptId -> ConceptId -> [ConceptId] -extractFromBodyLinkingTo sourceId targetId = - extractConceptLinks - (conceptFromDocument sourceId (OKFDocument (setType "Test" emptyFrontmatter) ("See " <> renderConceptLink targetId "link" <> ".\n"))) - -testRejectOverEscapingRelativeLink :: Either Text () -testRejectOverEscapingRelativeLink = do - sourceId <- parseTestConceptId "a/b/source" - targetId <- parseTestConceptId "tables/orders" - let concept = - conceptFromDocument - sourceId - (OKFDocument (setType "Test" emptyFrontmatter) "[Escapes](../../../tables/orders.md)\n") - assertEqual [] (extractConceptLinks concept) - assertEqual [] (validateBundle PermissiveConformance [concept, targetConcept targetId]) - where - targetConcept targetId = - conceptFromDocument - targetId - (OKFDocument (setType "Test" emptyFrontmatter) "# Orders\n") - -testValidateBundleDanglingReference :: Either Text () -testValidateBundleDanglingReference = do - aId <- parseTestConceptId "a" - bId <- parseTestConceptId "b" - conceptA <- testConcept "a" ("See " <> renderConceptLink bId "b" <> ".\n") - assertEqual [DanglingReference aId bId] (validateBundle StrictAuthoring [conceptA]) - -testValidateBundleAcceptsResolved :: Either Text () -testValidateBundleAcceptsResolved = do - bId <- parseTestConceptId "b" - conceptA <- testConcept "a" ("See " <> renderConceptLink bId "b" <> ".\n") - conceptB <- testConcept "b" "Standalone.\n" - assertEqual [] (validateBundle StrictAuthoring [conceptA, conceptB]) - -testDuplicateConceptIds :: Either Text () -testDuplicateConceptIds = do - aId <- parseTestConceptId "a" - conceptA <- testConcept "a" "First.\n" - conceptAAgain <- testConcept "a" "Second.\n" - assertEqual [aId] (duplicateConceptIds [conceptA, conceptAAgain]) - --- | Build an in-memory concept via the public 'conceptFromDocument' constructor, --- so its typed fields are derived from the frontmatter and cannot diverge. --- Includes all StrictAuthoring fields so per-document validation passes and --- bundle-level checks can be isolated. -testConcept :: Text -> Text -> Either Text Concept -testConcept rawId bodyText = do - conceptId <- parseTestConceptId rawId - let frontmatterValue = - okfCommon - OkfCommon - { commonType = "Test", - commonTitle = Just "Title", - commonDescription = Just "Description", - commonTimestamp = Just "2026-06-16T00:00:00Z" - } - pure (conceptFromDocument conceptId (OKFDocument frontmatterValue bodyText)) - -testConceptWithTimestamp :: Text -> Text -> Either Text Concept -testConceptWithTimestamp rawId timestamp = do - conceptId <- parseTestConceptId rawId - let frontmatterValue = - okfCommon - OkfCommon - { commonType = "Test", - commonTitle = Just "Title", - commonDescription = Just "Description", - commonTimestamp = Just timestamp - } - pure (conceptFromDocument conceptId (OKFDocument frontmatterValue "# Test\n")) - -testConceptFromDocumentDerivesFields :: Either Text () -testConceptFromDocumentDerivesFields = do - conceptId <- parseTestConceptId "tables/orders" - let frontmatterValue = - okfCommon - OkfCommon - { commonType = "BigQuery Table", - commonTitle = Just "Orders", - commonDescription = Nothing, - commonTimestamp = Nothing - } - concept = conceptFromDocument conceptId (OKFDocument frontmatterValue "# Orders\n") - assertEqual "BigQuery Table" (conceptType concept) - assertEqual (Just "Orders") (conceptTitle concept) - assertEqual "tables/orders.md" (conceptSourcePath concept) - -testWriteBundleRoundTrip :: IO (Either Text ()) -testWriteBundleRoundTrip = do - temporaryDirectory <- getTemporaryDirectory - root <- createTempDirectory temporaryDirectory "okf-core-writebundle" - let buildConcepts = do - orders <- testConcept "tables/orders" "# Orders\n\nOrder records.\n" - customers <- testConcept "tables/customers" "# Customers\n\nCustomer records.\n" - pure [orders, customers] - case buildConcepts of - Left message -> do - removeDirectoryRecursive root - pure (Left message) - Right concepts -> do - writeBundle root concepts - recovered <- readBundle root - removeDirectoryRecursive root - pure - ( do - assertEqual - (List.sort (renderConceptId . conceptIdOf <$> concepts)) - (List.sort (renderConceptId . conceptIdOf <$> recovered)) - assertEqual - (List.sort ((body . conceptDocument) <$> concepts)) - (List.sort ((body . conceptDocument) <$> recovered)) - ) - -testFixtureDanglingLink :: IO (Either Text ()) -testFixtureDanglingLink = do - root <- fixturePath "invalid-dangling-link" - concepts <- readBundle root - pure - ( case validateBundle PermissiveConformance concepts of - errs - | any isDangling errs -> Right () - | otherwise -> Left ("expected a DanglingReference, got: " <> Text.pack (show errs)) - ) - where - isDangling DanglingReference {} = True - isDangling _ = False - --- | Resolve a fixture file path regardless of whether tests run from the repo --- root or the package directory (mirrors 'fixturePath' for files). -fixtureFilePath :: FilePath -> IO FilePath -fixtureFilePath name = findExisting candidates - where - candidates = - [ "okf-core" "test" "fixtures" name, - "test" "fixtures" name - ] - findExisting [] = fail ("fixture file not found: " <> name) - findExisting (candidate : rest) = do - exists <- doesFileExist candidate - if exists then pure candidate else findExisting rest - --- | Milestone 1: the Dhall descriptor round-trips into a 'ProfileSpec'. -testLoadProfileFixture :: IO (Either Text ()) -testLoadProfileFixture = do - path <- fixtureFilePath "profiles/postgresql.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load profile: " <> err) - Right spec -> do - assertEqual "shinzui-postgresql" (spec ^. #name) - assertEqual - (Just "Conventions for documenting a PostgreSQL database as an OKF bundle.") - (spec ^. #description) - assertEqual False (spec ^. #allowUnknownTypes) - assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) - assertEqual - [ Just "The OKF concept type; must be one of the type rules below.", - Just "Human-readable name of the object, as a reader would say it." - ] - (map (^. #description) (spec ^. #frontmatter . #required)) - -- `timestamp` is written with bare record completion, so it carries no prose. - assertEqual - [ Just "One or two sentences on what this object is for.", - Nothing, - Just "postgresql:// URI locating the live object." - ] - (map (^. #description) (spec ^. #frontmatter . #recommended)) - assertEqual - ["PostgreSQL Schema", "PostgreSQL Table", "PostgreSQL View"] - (map (^. #type_) (spec ^. #types)) - assertEqual - (Just "One physical table in a schema, including its column list.") - (spec ^. #types . to (!! 1) . #description) - -testLoadDocumentIdProfileFixture :: IO (Either Text ()) -testLoadDocumentIdProfileFixture = do - path <- fixtureFilePath "profiles/decisions.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load document ID profile: " <> err) - Right spec -> do - assertEqual (Just "docId") (spec ^. #idField) - assertEqual [Just "ADR"] (map (^. #idPrefix) (spec ^. #types)) - -- Written with the mk/FieldRule.dhall constructors, which normalize to - -- exactly what record completion produces. - assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) - assertEqual - [Just "The OKF concept type; must be a type rule below.", Nothing] - (map (^. #description) (spec ^. #frontmatter . #required)) - -testLoadDescribedProfileFixture :: IO (Either Text ()) -testLoadDescribedProfileFixture = do - path <- fixtureFilePath "profiles/described.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load described profile: " <> err) - Right spec -> do - assertEqual "described" (spec ^. #name) - assertEqual ["Described Concept"] (map (^. #type_) (spec ^. #types)) - assertEqual [emptyTestFrontmatterRules] (map (^. #frontmatter) (spec ^. #types)) - assertEqual True (spec ^. #allowUnknownFields) - assertEqual [[]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) - assertEqual [Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - -testLoadTypeAwareCompatibilityFixture :: IO (Either Text ()) -testLoadTypeAwareCompatibilityFixture = do - path <- fixtureFilePath "profiles/type-aware-ep1.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load EP-1 profile: " <> err) - Right spec -> do - assertEqual "type-aware-ep1" (spec ^. #name) - assertEqual True (spec ^. #allowUnknownFields) - assertEqual [[]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) - assertEqual [[[]]] (map (map (^. #allowedValues) . (^. #frontmatter . #required)) (spec ^. #types)) - assertEqual [Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - -testLoadVocabularyCompatibilityFixture :: IO (Either Text ()) -testLoadVocabularyCompatibilityFixture = do - path <- fixtureFilePath "profiles/vocabulary-ep2.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load EP-2 profile: " <> err) - Right spec -> do - assertEqual "vocabulary-ep2" (spec ^. #name) - assertEqual False (spec ^. #allowUnknownFields) - assertEqual [[], ["draft", "accepted"]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) - assertEqual [Any, Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - assertEqual [Nothing, Nothing] (map (^. #format) (spec ^. #frontmatter . #required)) - -testLoadCardinalityCompatibilityFixture :: IO (Either Text ()) -testLoadCardinalityCompatibilityFixture = do - path <- fixtureFilePath "profiles/cardinality-ep3.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load EP-3 profile: " <> err) - Right spec -> do - assertEqual "cardinality-ep3" (spec ^. #name) - assertEqual False (spec ^. #allowUnknownFields) - assertEqual [Any, Scalar] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - assertEqual [Nothing, Nothing] (map (^. #format) (spec ^. #frontmatter . #required)) - -testLoadFormatCompatibilityFixture :: IO (Either Text ()) -testLoadFormatCompatibilityFixture = do - path <- fixtureFilePath "profiles/formats-ep4.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load EP-4 profile: " <> err) - Right spec -> do - assertEqual "formats-ep4" (spec ^. #name) - assertEqual [Any, Scalar] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - assertEqual [Nothing, Just Rfc3339Utc] (map (^. #format) (spec ^. #frontmatter . #required)) - assertEqual [Nothing, Nothing] (map (^. #elementFields) (spec ^. #frontmatter . #required)) - -testLoadNestedReviewsProfileFixture :: IO (Either Text ()) -testLoadNestedReviewsProfileFixture = do - path <- fixtureFilePath "profiles/nested-reviews.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load nested review profile: " <> err) - Right spec -> - case [rules | rule <- spec ^. #frontmatter . #required, rule ^. #field == "reviews", Just rules <- [rule ^. #elementFields]] of - [NestedRules {required, recommended}] -> do - assertEqual ["kind", "reviewer", "reviewed_at", "document_timestamp", "scope", "outcome", "context"] (map (^. #field) required) - assertEqual ["notes"] (map (^. #field) recommended) - _ -> Left "expected exactly one reviews rule with elementFields" - -testLoadNestedCompatibilityFixture :: IO (Either Text ()) -testLoadNestedCompatibilityFixture = do - path <- fixtureFilePath "profiles/nested-reviews-ep1.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load frozen nested profile: " <> err) - Right spec -> - case spec ^. #frontmatter . #required of - [rule] -> do - assertEqual Nothing (rule ^. #when) - case rule ^. #elementFields of - Just NestedRules {required = [nestedRule]} -> do - assertEqual "kind" (nestedRule ^. #field) - assertEqual Nothing (nestedRule ^. #when) - _ -> Left "expected the frozen nested rule to survive the compatibility upgrade" - _ -> Left "expected one frozen top-level rule" - -testLoadConditionalFieldsProfileFixture :: IO (Either Text ()) -testLoadConditionalFieldsProfileFixture = do - path <- fixtureFilePath "profiles/conditional-fields.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load conditional profile: " <> err) - Right spec -> do - assertEqual "conditional-fields" (spec ^. #name) - compiled <- firstShow (compileProfile spec) - assertEqual spec (compiledProfileSpec compiled) - -testLoadConditionalCompatibilityFixture :: IO (Either Text ()) -testLoadConditionalCompatibilityFixture = do - path <- fixtureFilePath "profiles/conditional-fields-ep2.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load frozen condition-aware profile: " <> err) - Right spec -> - case spec ^. #frontmatter . #required of - [sourceRule, targetRule, reviewsRule] -> do - assertEqual Nothing (sourceRule ^. #reference) - assertEqual (Just (FieldCondition "status" ["superseded"])) (targetRule ^. #when) - assertEqual Nothing (targetRule ^. #reference) - case reviewsRule ^. #elementFields of - Just NestedRules {required = [_kindRule, providerRule]} -> - assertEqual (Just (FieldCondition "kind" ["model"])) (providerRule ^. #when) - _ -> Left "expected frozen nested conditions to survive the compatibility upgrade" - _ -> Left "expected three frozen condition-aware top-level rules" - --- | The immediately preceding generation: a descriptor that spells out the --- reference-aware record types with no @optional@ list anywhere still loads, --- keeps every field it did declare, and behaves as though each optional list --- were empty. -testLoadReferenceCompatibilityFixture :: IO (Either Text ()) -testLoadReferenceCompatibilityFixture = do - path <- fixtureFilePath "profiles/document-references-ep3.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load frozen reference-aware profile: " <> err) - Right spec -> do - assertEqual [] (spec ^. #frontmatter . #optional) - assertEqual [[]] (map (^. #frontmatter . #optional) (spec ^. #types)) - case spec ^. #frontmatter . #recommended of - [referenceRule, conditionRule, reviewsRule] -> do - assertEqual - (Just (HandleReferenceRule "ADR" ["mori"] False)) - (referenceRule ^. #reference) - assertEqual (Just (FieldCondition "status" ["superseded"])) (conditionRule ^. #when) - case reviewsRule ^. #elementFields of - Just NestedRules {required = [kindRule], recommended = [notesRule], optional = nestedOptional} -> do - assertEqual "kind" (kindRule ^. #field) - assertEqual "notes" (notesRule ^. #field) - assertEqual [] (map (^. #field) nestedOptional) - _ -> Left "expected the frozen nested rules to survive with an empty optional list" - _ -> Left "expected three frozen reference-aware recommended rules" - --- | The backwards-compatibility guarantee: a descriptor frozen in the okf 0.2.x --- shape — bare-string frontmatter keys, no descriptions anywhere — still loads, --- via the legacy fallback decoder, with every description absent. -testLoadLegacyProfileFixture :: IO (Either Text ()) -testLoadLegacyProfileFixture = do - path <- fixtureFilePath "profiles/legacy-0.2.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load legacy profile: " <> err) - Right spec -> do - assertEqual "legacy" (spec ^. #name) - assertEqual Nothing (spec ^. #description) - assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) - assertEqual [Nothing, Nothing] (map (^. #description) (spec ^. #frontmatter . #required)) - assertEqual ["Legacy Concept"] (map (^. #type_) (spec ^. #types)) - assertEqual [Nothing] (map (^. #description) (spec ^. #types)) - assertEqual True (spec ^. #allowUnknownFields) - assertEqual [[], []] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) - assertEqual [Any, Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) - -testProfileFieldDescription :: IO (Either Text ()) -testProfileFieldDescription = do - path <- fixtureFilePath "profiles/postgresql.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load profile: " <> err) - Right spec -> do - assertEqual - (Just "Human-readable name of the object, as a reader would say it.") - (profileFieldDescription spec "title") - assertEqual - (Just "postgresql:// URI locating the live object.") - (profileFieldDescription spec "resource") - assertEqual Nothing (profileFieldDescription spec "timestamp") - assertEqual Nothing (profileFieldDescription spec "nope") - --- | Prose declared on an optional rule is as discoverable as prose on a required --- or recommended one; the third list is searched last, after the two that can --- produce a missing-field diagnostic. -testOptionalFieldDescription :: IO (Either Text ()) -testOptionalFieldDescription = do - path <- fixtureFilePath "profiles/decisions.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load decisions profile: " <> err) - Right spec -> - assertEqual - (Just "The decision this one replaces, when it replaces one.") - (profileFieldDescription spec "supersedes") - --- | The JSON encoding is pinned field by field, so a future refactor cannot --- silently rename a key. The @type@ key matters most: the Haskell field is --- @type_@, and consumers must never see that. -testProfileJsonShape :: IO (Either Text ()) -testProfileJsonShape = do - path <- fixtureFilePath "profiles/decisions.dhall" - result <- loadProfileFile path - pure $ case result of - Left err -> Left ("failed to load document ID profile: " <> err) - Right spec -> - assertEqual - ( object - [ "name" .= ("decisions" :: Text), - "description" .= ("How this team records architectural decisions." :: Text), - "okfVersion" .= ("0.1" :: Text), - "allowUnknownTypes" .= False, - "allowUnknownFields" .= True, - "idField" .= ("docId" :: Text), - "frontmatter" - .= object - [ "required" - .= [ object - [ "field" .= ("type" :: Text), - "description" - .= ("The OKF concept type; must be a type rule below." :: Text), - "allowedValues" .= ([] :: [Text]), - "cardinality" .= ("any" :: Text), - "format" .= (Nothing :: Maybe Text), - "elementFields" .= (Nothing :: Maybe Value), - "reference" .= (Nothing :: Maybe HandleReferenceRule), - "when" .= (Nothing :: Maybe FieldCondition) - ], - object - [ "field" .= ("title" :: Text), - "description" .= (Nothing :: Maybe Text), - "allowedValues" .= ([] :: [Text]), - "cardinality" .= ("any" :: Text), - "format" .= (Nothing :: Maybe Text), - "elementFields" .= (Nothing :: Maybe Value), - "reference" .= (Nothing :: Maybe HandleReferenceRule), - "when" .= (Nothing :: Maybe FieldCondition) - ] - ], - "recommended" - .= [ object - [ "field" .= ("status" :: Text), - "description" - .= ("One of: proposed, accepted, superseded." :: Text), - "allowedValues" .= ([] :: [Text]), - "cardinality" .= ("any" :: Text), - "format" .= (Nothing :: Maybe Text), - "elementFields" .= (Nothing :: Maybe Value), - "reference" .= (Nothing :: Maybe HandleReferenceRule), - "when" .= (Nothing :: Maybe FieldCondition) - ] - ], - "optional" - .= [ object - [ "field" .= ("supersedes" :: Text), - "description" - .= ("The decision this one replaces, when it replaces one." :: Text), - "allowedValues" .= ([] :: [Text]), - "cardinality" .= ("any" :: Text), - "format" .= (Nothing :: Maybe Text), - "elementFields" .= (Nothing :: Maybe Value), - "reference" .= (Nothing :: Maybe HandleReferenceRule), - "when" .= (Nothing :: Maybe FieldCondition) - ] - ] - ], - "types" - .= [ object - [ "type" .= ("Decision Record" :: Text), - "description" - .= ("One accepted decision, never edited after acceptance." :: Text), - "frontmatter" - .= object - [ "required" .= ([] :: [FieldRule]), - "recommended" .= ([] :: [FieldRule]), - "optional" .= ([] :: [FieldRule]) - ], - "pathPattern" .= ("decisions/*" :: Text), - "resourceScheme" .= (Nothing :: Maybe Text), - "requireSchemaSection" .= False, - "schemaColumns" .= ([] :: [Text]), - "idPrefix" .= ("ADR" :: Text) - ] - ] - ] - ) - (toJSON spec) - -testFieldFormatJsonShape :: Either Text () -testFieldFormatJsonShape = - assertEqual - [ String "rfc3339-utc", - String "date", - String "uri", - object ["uriWithScheme" .= ("mori" :: Text)], - object ["documentHandle" .= ("ADR" :: Text)] - ] - (map toJSON [Rfc3339Utc, Date, Uri, UriWithScheme "mori", DocumentHandle "ADR"]) - -testFieldConditionJsonShape :: Either Text () -testFieldConditionJsonShape = - assertEqual - (object ["field" .= ("status" :: Text), "hasValue" .= (["superseded"] :: [Text])]) - (toJSON (FieldCondition "status" ["superseded"])) - -testHandleReferenceJsonShape :: Either Text () -testHandleReferenceJsonShape = - assertEqual - ( object - [ "localPrefix" .= ("ADR" :: Text), - "externalUriSchemes" .= (["mori", "https"] :: [Text]), - "allowSelf" .= False - ] - ) - (toJSON (HandleReferenceRule "ADR" ["mori", "https"] False)) - --- | A registry record enumerates every field that decodes as a profile, one --- level down as well as at the top, sorted by export path. The @Profile@ schema --- record and the @note@ string contribute nothing. -testRegistryEnumeratesProfiles :: IO (Either Text ()) -testRegistryEnumeratesProfiles = do - path <- fixtureFilePath "registry/package.dhall" - loaded <- loadRegistry (RegistryFile path) - pure $ case loaded of - Left err -> Left ("failed to load fixture registry: " <> err) - Right entries -> do - -- `legacy` is a frozen okf 0.2.x descriptor: it enumerates only because - -- the registry walk falls back to the legacy decoder. - assertEqual ["legacy", "nested.decisions", "postgresql"] (map (^. #export) entries) - case findRegistryEntry "legacy" entries of - Nothing -> Left "expected an entry at export path legacy" - Just entry -> do - assertEqual "legacy" (entry ^. #spec . #name) - assertEqual Nothing (entry ^. #spec . #description) - case findRegistryEntry "postgresql" entries of - Nothing -> Left "expected an entry at export path postgresql" - Just entry -> assertEqual "shinzui-postgresql" (entry ^. #spec . #name) - assertEqual Nothing (findRegistryEntry "nope" entries) - assertBool - "expected findRegistryEntry to resolve the nested export" - (isJust (findRegistryEntry "nested.decisions" entries)) - --- | A registry reference that is itself a profile yields one entry whose export --- path is empty. -testRegistryRootProfile :: IO (Either Text ()) -testRegistryRootProfile = do - path <- fixtureFilePath "profiles/decisions.dhall" - loaded <- loadRegistry (RegistryFile path) - pure $ case loaded of - Left err -> Left ("failed to load root profile registry: " <> err) - Right entries -> do - assertEqual [""] (map (^. #export) entries) - assertEqual ["decisions"] (map (^. #spec . #name) entries) - --- | A directory holding @package.dhall@ resolves to that file; anything else --- is handed to Dhall verbatim. -testResolveRegistryRef :: IO (Either Text ()) -testResolveRegistryRef = do - directory <- fixturePath "registry" - resolvedDirectory <- resolveRegistryRef (Text.pack directory) - filePath <- fixtureFilePath "profiles/decisions.dhall" - resolvedFile <- resolveRegistryRef (Text.pack filePath) - resolvedExpression <- resolveRegistryRef "./nowhere/at/all.dhall" - pure $ do - assertEqual (RegistryFile (directory "package.dhall")) resolvedDirectory - assertEqual (RegistryFile filePath) resolvedFile - assertEqual (RegistryExpression "./nowhere/at/all.dhall") resolvedExpression - --- | A reference that cannot be evaluated reports an error rather than throwing. -testRegistryLoadFailure :: IO (Either Text ()) -testRegistryLoadFailure = do - loaded <- loadRegistry (RegistryFile "/nonexistent/registry.dhall") - pure $ case loaded of - Right entries -> Left ("expected a load failure, got " <> Text.pack (show (length entries)) <> " entries") - Left message -> assertBool "expected a non-empty error message" (not (Text.null message)) - -testParseDocumentId :: Either Text () -testParseDocumentId = do - assertEqual - (Just (DocumentId {prefix = "ADR", number = 7})) - (parseDocumentId "ADR-7") - mapM_ - (\invalid -> assertEqual Nothing (parseDocumentId invalid)) - ["ADR-007", "ADR-0", "ADR-", "-7", "ADR 7", "ADR-7-extra"] - assertEqual (Just "ADR-7") (renderDocumentId <$> parseDocumentId "ADR-7") - -testDocumentIdsInBundle :: IO (Either Text ()) -testDocumentIdsInBundle = do - descriptorPath <- fixtureFilePath "profiles/decisions.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "doc-ids" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load document ID profile: " <> err) - Right spec -> do - useMarkdown <- parseTestConceptId "decisions/use-markdown" - usePostgres <- parseTestConceptId "decisions/use-postgres" - adoptOkf <- parseTestConceptId "decisions/adopt-okf" - assertEqual - [ (DocumentId "ADR" 1, useMarkdown), - (DocumentId "ADR" 2, usePostgres), - (DocumentId "ADR" 3, adoptOkf) - ] - (documentIdsInBundle spec concepts) - -testNextDocumentId :: Either Text () -testNextDocumentId = do - firstConcept <- - profileConcept - "decisions/first" - [("type", String "Decision Record"), ("title", String "First"), ("docId", String "ADR-1")] - "# First\n" - thirdConcept <- - profileConcept - "decisions/third" - [("type", String "Decision Record"), ("title", String "Third"), ("docId", String "ADR-3")] - "# Third\n" - let concepts = [firstConcept, thirdConcept] - assertEqual (DocumentId "ADR" 4) (nextDocumentId testDocumentIdProfileSpec concepts "ADR") - assertEqual (DocumentId "RFC" 1) (nextDocumentId testDocumentIdProfileSpec concepts "RFC") - -testFindConceptsByDocumentId :: IO (Either Text ()) -testFindConceptsByDocumentId = do - validRoot <- fixturePath "doc-ids" - validConcepts <- readBundle validRoot - deviationRoot <- fixturePath "doc-id-deviations" - deviationConcepts <- readBundle deviationRoot - pure $ do - usePostgres <- parseTestConceptId "decisions/use-postgres" - firstId <- parseTestConceptId "decisions/first" - secondId <- parseTestConceptId "decisions/second" - assertEqual - [usePostgres] - (conceptIdOf <$> findConceptsByDocumentId Nothing "ADR-2" validConcepts) - assertEqual - [firstId, secondId] - (conceptIdOf <$> findConceptsByDocumentId (Just "docId") "ADR-1" deviationConcepts) - --- | An undocumented frontmatter key: the validation tests care about names, not --- prose, and descriptions never affect validation. -requiredField :: Text -> FieldRule -requiredField key = FieldRule {field = key, description = Nothing, allowedValues = [], cardinality = Any, format = Nothing, elementFields = Nothing, reference = Nothing, when = Nothing} - --- | A standalone profile literal so the validation tests do not depend on the --- Dhall fixture. One rule: PostgreSQL Table, fully constrained. -testProfileSpec :: ProfileSpec -testProfileSpec = - ProfileSpec - { name = "test-postgresql", - description = Nothing, - okfVersion = "0.1", - frontmatter = - FrontmatterRules - { required = [requiredField "type", requiredField "title"], - recommended = [], - optional = [] - }, - allowUnknownTypes = False, - allowUnknownFields = True, - idField = Nothing, - types = - [ TypeRule - { type_ = "PostgreSQL Table", - description = Nothing, - frontmatter = emptyTestFrontmatterRules, - pathPattern = Just "schemas/*/tables/*", - resourceScheme = Just "postgresql", - requireSchemaSection = True, - schemaColumns = ["Column", "Type", "Nullable", "Description"], - idPrefix = Nothing - } - ] - } - -testDocumentIdProfileSpec :: ProfileSpec -testDocumentIdProfileSpec = - ProfileSpec - { name = "test-decisions", - description = Nothing, - okfVersion = "0.1", - frontmatter = - FrontmatterRules - { required = [requiredField "type", requiredField "title"], - recommended = [], - optional = [] - }, - allowUnknownTypes = False, - allowUnknownFields = True, - idField = Just "docId", - types = - [ TypeRule - { type_ = "Decision Record", - description = Nothing, - frontmatter = emptyTestFrontmatterRules, - pathPattern = Just "decisions/*", - resourceScheme = Nothing, - requireSchemaSection = False, - schemaColumns = [], - idPrefix = Just "ADR" - } - ] - } - -emptyTestFrontmatterRules :: FrontmatterRules -emptyTestFrontmatterRules = FrontmatterRules {required = [], recommended = [], optional = []} - -typeAwareProfileSpec :: ProfileSpec -typeAwareProfileSpec = - ProfileSpec - { name = "type-aware", - description = Nothing, - okfVersion = "0.1", - frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, FieldRule "title" (Just "Global title.") [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "owner" (Just "Profile-level owner.") [] Any Nothing Nothing Nothing Nothing], - optional = [] - }, - allowUnknownTypes = True, - allowUnknownFields = True, - idField = Nothing, - types = - [ TypeRule - { type_ = "Owned Concept", - description = Nothing, - frontmatter = - FrontmatterRules - { required = [FieldRule "owner" (Just "Responsible person.") [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "reviewer" (Just "Second pair of eyes.") [] Any Nothing Nothing Nothing Nothing, FieldRule "title" (Just "Type title.") [] Any Nothing Nothing Nothing Nothing], - optional = [] - }, - pathPattern = Nothing, - resourceScheme = Nothing, - requireSchemaSection = False, - schemaColumns = [], - idPrefix = Nothing - } - ] - } - -testCompileProfileDefinitionErrors :: Either Text () -testCompileProfileDefinitionErrors = do - let duplicateField = FieldRule "title" Nothing [] Any Nothing Nothing Nothing Nothing - invalid = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [duplicateField, duplicateField], - recommended = [duplicateField], - optional = [] - }, - types = (typeAwareProfileSpec ^. #types) <> (typeAwareProfileSpec ^. #types) - } - case compileProfile invalid of - Right _ -> Left "expected invalid profile definition" - Left errors -> - assertEqual - [ DuplicateFieldRule Nothing "required" "title", - ConflictingFieldRequirement Nothing "title", - DuplicateTypeRule "Owned Concept" - ] - (toList errors) - -testCompiledProfileMerge :: Either Text () -testCompiledProfileMerge = do - compiled <- firstShow (compileProfile typeAwareProfileSpec) - assertEqual (Just "Type title.") (profileFieldDescriptionForType compiled "Owned Concept" "title") - assertEqual (Just "Responsible person.") (profileFieldDescriptionForType compiled "Owned Concept" "owner") - assertEqual (Just "Global title.") (profileFieldDescriptionForType compiled "Unknown Concept" "title") - concept <- profileConcept "owned/one" [("type", String "Owned Concept")] "# One\n" - cid <- parseTestConceptId "owned/one" - assertEqual - [MissingProfileField cid "owner" Nothing, MissingProfileField cid "title" Nothing] - (validateProfile PermissiveConformance compiled [concept]) - -vocabularyProfileSpec :: ProfileSpec -vocabularyProfileSpec = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "status" Nothing ["draft", "approved", "approved"] Any Nothing Nothing Nothing Nothing], - optional = [] - }, - types = - [ withTypeFrontmatter - FrontmatterRules - { required = [FieldRule "status" Nothing ["approved", "archived"] Any Nothing Nothing Nothing Nothing], - recommended = [], - optional = [] - } - (firstTypeRule typeAwareProfileSpec) - ] - } - -fieldPath :: Text -> FieldPath -fieldPath key = FieldPath (FieldName key :| []) - -testCompiledVocabularyIntersection :: Either Text () -testCompiledVocabularyIntersection = do - compiled <- firstShow (compileProfile vocabularyProfileSpec) - concept <- profileConcept "owned/one" [("type", String "Owned Concept"), ("status", String "draft")] "# One\n" - cid <- parseTestConceptId "owned/one" - assertEqual - [ValueNotInVocabulary cid (fieldPath "status") ["approved"] (String "draft")] - (validateProfile PermissiveConformance compiled [concept]) - -testUnsatisfiableVocabulary :: Either Text () -testUnsatisfiableVocabulary = do - let disjoint = - vocabularyProfileSpec - { types = - [ withTypeFrontmatter - FrontmatterRules - { required = [FieldRule "status" Nothing ["closed"] Any Nothing Nothing Nothing Nothing], - recommended = [], - optional = [] - } - (firstTypeRule vocabularyProfileSpec) - ] - } - assertEqual - (Left (UnsatisfiableVocabulary (Just "Owned Concept") "status" ["draft", "approved"] ["closed"] :| [])) - (compileProfile disjoint) - -testCompiledCardinality :: Either Text () -testCompiledCardinality = do - let profileRules = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "status" Nothing [] Scalar Nothing Nothing Nothing Nothing], - optional = [] - } - typeRules cardinality = - FrontmatterRules - { required = [FieldRule "status" Nothing [] cardinality Nothing Nothing Nothing Nothing], - recommended = [], - optional = [] - } - baseType = firstTypeRule typeAwareProfileSpec - compatible = - typeAwareProfileSpec - { frontmatter = profileRules, - types = [withTypeFrontmatter (typeRules Any) baseType] - } - contradictory = compatible {types = [withTypeFrontmatter (typeRules List) baseType]} - compiled <- firstShow (compileProfile compatible) - valid <- profileConcept "owned/cardinality" [("type", String "Owned Concept"), ("status", Number 3)] "# Valid\n" - invalid <- profileConcept "owned/cardinality" [("type", String "Owned Concept"), ("status", toJSON (["draft"] :: [Text]))] "# Invalid\n" - cid <- parseTestConceptId "owned/cardinality" - assertEqual [] (validateProfile PermissiveConformance compiled [valid]) - assertEqual - [CardinalityMismatch cid (fieldPath "status") Scalar (toJSON (["draft"] :: [Text]))] - (validateProfile PermissiveConformance compiled [invalid]) - assertEqual - (Left (ConflictingCardinality (Just "Owned Concept") "status" Scalar List :| [])) - (compileProfile contradictory) - -testVocabularyValidation :: Either Text () -testVocabularyValidation = do - let openVocabulary = - vocabularyProfileSpec - { frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "status" Nothing ["draft", "approved"] Any Nothing Nothing Nothing Nothing], - optional = [] - }, - types = [] - } - compiled <- firstShow (compileProfile openVocabulary) - validString <- profileConcept "valid-string" [("type", String "Extension"), ("status", String "draft")] "# Valid\n" - validList <- profileConcept "valid-list" [("type", String "Extension"), ("status", toJSON (["draft", "approved"] :: [Text]))] "# Valid\n" - absent <- profileConcept "absent" [("type", String "Extension")] "# Absent\n" - invalidString <- profileConcept "invalid-string" [("type", String "Extension"), ("status", String "banana")] "# Invalid\n" - invalidList <- profileConcept "invalid-list" [("type", String "Extension"), ("status", toJSON (["draft", "banana"] :: [Text]))] "# Invalid\n" - invalidShape <- profileConcept "invalid-shape" [("type", String "Extension"), ("status", toJSON (1 :: Int))] "# Invalid\n" - invalidStringId <- parseTestConceptId "invalid-string" - invalidListId <- parseTestConceptId "invalid-list" - invalidShapeId <- parseTestConceptId "invalid-shape" - assertEqual [] (validateProfile PermissiveConformance compiled [validString, validList, absent]) - assertEqual - [ValueNotInVocabulary invalidStringId (fieldPath "status") ["draft", "approved"] (String "banana")] - (validateProfile PermissiveConformance compiled [invalidString]) - assertEqual - [ValueNotInVocabulary invalidListId (fieldPath "status") ["draft", "approved"] (toJSON (["draft", "banana"] :: [Text]))] - (validateProfile PermissiveConformance compiled [invalidList]) - assertEqual - [ValueNotInVocabulary invalidShapeId (fieldPath "status") ["draft", "approved"] (toJSON (1 :: Int))] - (validateProfile PermissiveConformance compiled [invalidShape]) - -testCardinalityValidation :: Either Text () -testCardinalityValidation = do - cid <- parseTestConceptId "cardinality" - let check cardinality actual = do - compiled <- firstShow (compileProfile (singleCardinalityProfile True cardinality [])) - concept <- profileConcept "cardinality" [("type", String "Extension"), ("value", actual)] "# Cardinality\n" - pure (validateProfile PermissiveConformance compiled [concept]) - mismatch cardinality actual = [CardinalityMismatch cid (fieldPath "value") cardinality actual] - objectValue = object ["nested" .= (True :: Bool)] - textList = toJSON (["one"] :: [Text]) - emptyList = toJSON ([] :: [Text]) - for_ [String "one", Number 0, Bool False] $ \actual -> - check Scalar actual >>= assertEqual [] - for_ [textList, objectValue, Null] $ \actual -> - check Scalar actual >>= assertEqual (mismatch Scalar actual) - check List textList >>= assertEqual [] - for_ [String "one", Number 0, Bool False, objectValue, Null] $ \actual -> - check List actual >>= assertEqual (mismatch List actual) - check Any (String "one") >>= assertEqual [] - check Any textList >>= assertEqual [] - check Any (Bool False) >>= assertEqual [MissingProfileField cid "value" Nothing] - check Scalar (String " ") >>= assertEqual [MissingProfileField cid "value" Nothing] - check List emptyList >>= assertEqual [MissingProfileField cid "value" Nothing] - optionalCompiled <- firstShow (compileProfile (singleCardinalityProfile False Scalar [])) - optionalConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", textList)] "# Optional\n" - assertEqual - (mismatch Scalar textList) - (validateProfile PermissiveConformance optionalCompiled [optionalConcept]) - -testCardinalityVocabularyInteraction :: Either Text () -testCardinalityVocabularyInteraction = do - cid <- parseTestConceptId "cardinality" - scalarCompiled <- firstShow (compileProfile (singleCardinalityProfile True Scalar ["draft"])) - let objectValue = object ["status" .= ("draft" :: Text)] - objectConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", objectValue)] "# Object\n" - assertEqual - [CardinalityMismatch cid (fieldPath "value") Scalar objectValue] - (validateProfile PermissiveConformance scalarCompiled [objectConcept]) - listCompiled <- firstShow (compileProfile (singleCardinalityProfile True List ["draft"])) - let mixedList = toJSON ([String "draft", Number 1] :: [Value]) - listConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", mixedList)] "# List\n" - assertEqual - [ValueNotInVocabulary cid (fieldPath "value") ["draft"] mixedList] - (validateProfile PermissiveConformance listCompiled [listConcept]) - -testCompiledFieldFormats :: Either Text () -testCompiledFieldFormats = do - let baseType = firstTypeRule typeAwareProfileSpec - profileWith profileFormat typeFormat = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, FieldRule "homepage" Nothing [] Any (Just profileFormat) Nothing Nothing Nothing], - recommended = [], - optional = [] - }, - types = - [ withTypeFrontmatter - FrontmatterRules - { required = [FieldRule "homepage" Nothing [] Any (Just typeFormat) Nothing Nothing Nothing], - recommended = [], - optional = [] - } - baseType - ] - } - refined <- firstShow (compileProfile (profileWith Uri (UriWithScheme "https"))) - valid <- profileConcept "format-refinement" [("type", String "Owned Concept"), ("homepage", String "HTTPS://example.test/path")] "# Valid\n" - invalid <- profileConcept "format-refinement" [("type", String "Owned Concept"), ("homepage", String "http://example.test/path")] "# Invalid\n" - cid <- parseTestConceptId "format-refinement" - assertEqual [] (validateProfile PermissiveConformance refined [valid]) - assertEqual - [ValueFormatMismatch cid (fieldPath "homepage") (UriWithScheme "https") (String "http://example.test/path")] - (validateProfile PermissiveConformance refined [invalid]) - assertEqual - (Left (ConflictingFieldFormat (fieldPath "homepage") Date Rfc3339Utc :| [])) - (compileProfile (profileWith Date Rfc3339Utc)) - -testInvalidFormatParameters :: Either Text () -testInvalidFormatParameters = do - let invalid = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = - [ FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, - FieldRule "handle" Nothing [] Any (Just (DocumentHandle "1ADR")) Nothing Nothing Nothing, - FieldRule "source" Nothing [] Any (Just (UriWithScheme "https_")) Nothing Nothing Nothing - ], - recommended = [], - optional = [] - }, - types = [] - } - assertEqual - ( Left - ( InvalidFormatParameter (fieldPath "handle") (DocumentHandle "1ADR") "1ADR" - :| [InvalidFormatParameter (fieldPath "source") (UriWithScheme "https_") "https_"] - ) - ) - (compileProfile invalid) - -testNamedFormatValidation :: Either Text () -testNamedFormatValidation = do - cid <- parseTestConceptId "format" - let check fieldFormat cardinality actual = do - compiled <- firstShow (compileProfile (singleFormatProfile cardinality fieldFormat)) - concept <- - profileConcept - "format" - ([("type", String "Extension")] <> maybe [] (\value -> [("value", value)]) actual) - "# Format\n" - pure (validateProfile PermissiveConformance compiled [concept]) - mismatch fieldFormat actual = [ValueFormatMismatch cid (fieldPath "value") fieldFormat actual] - for_ ["2024-02-29T23:59:59Z", "2026-07-29T17:00:00.125Z"] $ \value -> - check Rfc3339Utc Any (Just (String value)) >>= assertEqual [] - for_ ["2026-13-45T99:99:99Z", "2026-07-29T17:00:00+01:00", "2026-07-29 17:00:00Z"] $ \value -> - check Rfc3339Utc Any (Just (String value)) >>= assertEqual (mismatch Rfc3339Utc (String value)) - check Date Any (Just (String "2024-02-29")) >>= assertEqual [] - for_ ["2023-02-29", "2026-13-01", "2026-07-29T00:00:00Z"] $ \value -> - check Date Any (Just (String value)) >>= assertEqual (mismatch Date (String value)) - for_ ["https://example.test/path", "urn:example:item"] $ \value -> - check Uri Any (Just (String value)) >>= assertEqual [] - for_ ["relative/path", "https://example.test/bad%ZZ"] $ \value -> - check Uri Any (Just (String value)) >>= assertEqual (mismatch Uri (String value)) - check (UriWithScheme "mori") Any (Just (String "MORI://haskell/time")) >>= assertEqual [] - check (UriWithScheme "mori") Any (Just (String "https://example.test")) - >>= assertEqual (mismatch (UriWithScheme "mori") (String "https://example.test")) - check (DocumentHandle "ADR") Any (Just (String "ADR-7")) >>= assertEqual [] - for_ ["ADR-007", "IR-7"] $ \value -> - check (DocumentHandle "ADR") Any (Just (String value)) - >>= assertEqual (mismatch (DocumentHandle "ADR") (String value)) - let validUris = toJSON (["https://example.test", "urn:example:item"] :: [Text]) - mixedUris = toJSON ([String "https://example.test", Number 1] :: [Value]) - check Uri List (Just validUris) >>= assertEqual [] - check Uri List (Just mixedUris) >>= assertEqual (mismatch Uri mixedUris) - check Uri Scalar (Just validUris) - >>= assertEqual [CardinalityMismatch cid (fieldPath "value") Scalar validUris] - check Uri Any (Just (Number 1)) >>= assertEqual (mismatch Uri (Number 1)) - check Uri Any Nothing >>= assertEqual [] - -singleFormatProfile :: Cardinality -> FieldFormat -> ProfileSpec -singleFormatProfile cardinality fieldFormat = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], - recommended = [FieldRule "value" Nothing [] cardinality (Just fieldFormat) Nothing Nothing Nothing], - optional = [] - }, - allowUnknownTypes = True, - types = [] - } - -singleCardinalityProfile :: Bool -> Cardinality -> [Text] -> ProfileSpec -singleCardinalityProfile isRequired cardinality allowed = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [FieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing] <> [rule | isRequired], - recommended = [rule | not isRequired], - optional = [] - }, - allowUnknownTypes = True, - types = [] - } - where - rule = FieldRule "value" Nothing allowed cardinality Nothing Nothing Nothing Nothing - -testCompiledNestedRules :: Either Text () -testCompiledNestedRules = do - let profileRules = - NestedRules - { required = [NestedFieldRule "kind" Nothing ["decision", "implementation"] Any Nothing Nothing], - recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing], - optional = [] - } - typeRules = - NestedRules - { required = - [ NestedFieldRule "kind" Nothing ["implementation", "operations"] Any Nothing Nothing, - NestedFieldRule "outcome" Nothing ["approved", "rejected"] Any Nothing Nothing - ], - recommended = [], - optional = [] - } - base = nestedProfileWithRules Any profileRules (Just typeRules) - compiled <- firstShow (compileProfile base) - concept <- - profileConcept - "reviewed/merge" - [ ("type", String "Reviewed Concept"), - ( "reviews", - toJSON - [ object - [ "kind" .= ("decision" :: Text), - "outcome" .= ("approved" :: Text) - ] - ] - ) - ] - "# Merge\n" - cid <- parseTestConceptId "reviewed/merge" - assertEqual - [ ValueNotInVocabulary - cid - (nestedTestPath 0 "kind") - ["implementation"] - (String "decision") - ] - (validateProfile PermissiveConformance compiled [concept]) - let impossible = nestedProfileWithRules Scalar profileRules Nothing - assertEqual - (Left (ElementFieldsRequireList Nothing (fieldPath "reviews") Scalar :| [])) - (compileProfile impossible) - -testNestedRecordValidation :: Either Text () -testNestedRecordValidation = do - compiled <- firstShow (compileProfile nestedReviewProfileSpec) - let firstReview = - object - [ "kind" .= ("human" :: Text), - "reviewer" .= ("Ari" :: Text), - "reviewed_at" .= ("2026-07-29T16:00:00Z" :: Text), - "document_timestamp" .= ("2026-07-29T17:00:00Z" :: Text), - "scope" .= ("content" :: Text), - "outcome" .= ("approved" :: Text), - "context" .= ("Complete" :: Text), - "notes" .= ("No blockers" :: Text), - "provider" .= ("allowed-extra-key" :: Text) - ] - thirdReview = - object - [ "kind" .= ("model" :: Text), - "reviewer" .= ("Bo" :: Text), - "reviewed_at" .= ("2026-13-45T99:99:99Z" :: Text), - "document_timestamp" .= ("2026-07-29T17:00:00Z" :: Text), - "scope" .= ("invalid" :: Text), - "context" .= (["wrong"] :: [Text]) - ] - reviewValues = toJSON [firstReview, String "not-a-record", thirdReview] - concept <- - profileConcept - "reviewed/bad" - [("type", String "Reviewed Concept"), ("reviews", reviewValues)] - "# Bad\n" - cid <- parseTestConceptId "reviewed/bad" - let permissiveExpected = - [ NestedElementNotRecord cid (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), - CardinalityMismatch cid (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), - MissingNestedProfileField cid (nestedTestPath 2 "outcome") Nothing, - ValueFormatMismatch cid (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), - ValueNotInVocabulary cid (nestedTestPath 2 "scope") reviewScopes (String "invalid") - ] - assertEqual permissiveExpected (validateProfile PermissiveConformance compiled [concept]) - assertEqual - [ NestedElementNotRecord cid (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), - CardinalityMismatch cid (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), - MissingRecommendedNestedProfileField cid (nestedTestPath 2 "notes") Nothing, - MissingNestedProfileField cid (nestedTestPath 2 "outcome") Nothing, - ValueFormatMismatch cid (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), - ValueNotInVocabulary cid (nestedTestPath 2 "scope") reviewScopes (String "invalid") - ] - (validateProfile StrictAuthoring compiled [concept]) - -nestedProfileWithRules :: Cardinality -> NestedRules -> Maybe NestedRules -> ProfileSpec -nestedProfileWithRules outerCardinality profileNested typeNested = - ProfileSpec - { name = "nested-merge", - description = Nothing, - okfVersion = "0.1", - frontmatter = - FrontmatterRules - { required = - [ requiredField "type", - FieldRule "reviews" Nothing [] outerCardinality Nothing (Just profileNested) Nothing Nothing - ], - recommended = [], - optional = [] - }, - allowUnknownTypes = False, - allowUnknownFields = True, - idField = Nothing, - types = - [ TypeRule - { type_ = "Reviewed Concept", - description = Nothing, - frontmatter = - FrontmatterRules - { required = maybe [] (\rules -> [FieldRule "reviews" Nothing [] Any Nothing (Just rules) Nothing Nothing]) typeNested, - recommended = [], - optional = [] - }, - pathPattern = Nothing, - resourceScheme = Nothing, - requireSchemaSection = False, - schemaColumns = [], - idPrefix = Nothing - } - ] - } - -nestedReviewProfileSpec :: ProfileSpec -nestedReviewProfileSpec = - nestedProfileWithRules Any nestedRules Nothing - where - nestedRules = - NestedRules - { required = - [ NestedFieldRule "kind" Nothing ["human", "model"] Any Nothing Nothing, - NestedFieldRule "reviewer" Nothing [] Scalar Nothing Nothing, - NestedFieldRule "reviewed_at" Nothing [] Any (Just Rfc3339Utc) Nothing, - NestedFieldRule "document_timestamp" Nothing [] Any (Just Rfc3339Utc) Nothing, - NestedFieldRule "scope" Nothing reviewScopes Any Nothing Nothing, - NestedFieldRule "outcome" Nothing ["approved", "changes-requested", "commented"] Any Nothing Nothing, - NestedFieldRule "context" Nothing [] Scalar Nothing Nothing - ], - recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing], - optional = [] - } - -nestedTestPath :: Int -> Text -> FieldPath -nestedTestPath elementIndex key = - FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) - -reviewScopes :: [Text] -reviewScopes = ["content", "technical-accuracy", "editorial", "catalog-metadata", "content-and-metadata"] - -testConditionDefinitionErrors :: Either Text () -testConditionDefinitionErrors = do - let source key values sourceCardinality = - FieldRule key Nothing values sourceCardinality Nothing Nothing Nothing Nothing - target key sourceKey values = - FieldRule key Nothing [] Any Nothing Nothing Nothing (Just (FieldCondition sourceKey values)) - compileWith rules = - compileProfile - typeAwareProfileSpec - { frontmatter = FrontmatterRules {required = rules, recommended = [], optional = []}, - allowUnknownTypes = True, - types = [] - } - targetPath key = fieldPath key - assertEqual - (Left (EmptyConditionValues Nothing (targetPath "target") (targetPath "status") :| [])) - (compileWith [source "status" ["active"] Scalar, target "target" "status" []]) - assertEqual - (Left (ConditionFieldNotDeclared Nothing (targetPath "target") (targetPath "missing") :| [])) - (compileWith [target "target" "missing" ["active"]]) - assertEqual - (Left (ConditionFieldNotScalar Nothing (targetPath "target") (targetPath "status") List :| [])) - (compileWith [source "status" ["active"] List, target "target" "status" ["active"]]) - assertEqual - (Left (ConditionFieldOpenVocabulary Nothing (targetPath "target") (targetPath "status") :| [])) - (compileWith [source "status" [] Scalar, target "target" "status" ["active"]]) - assertEqual - (Left (ConditionFieldHasUnreachableValues Nothing (targetPath "target") (targetPath "status") ["superseded"] ["active"] :| [])) - (compileWith [source "status" ["active"] Scalar, target "target" "status" ["superseded"]]) - assertEqual - (Left (SelfConditionalField Nothing (targetPath "status") :| [])) - (compileWith [FieldRule "status" Nothing ["active"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["active"]))]) - let nestedCrossScope = - NestedRules - { required = - [ NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing, - NestedFieldRule "provider" Nothing [] Scalar Nothing (Just (FieldCondition "status" ["active"])) - ], - recommended = [], - optional = [] - } - crossScopeProfile = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = - [ source "status" ["active"] Scalar, - FieldRule "reviews" Nothing [] List Nothing (Just nestedCrossScope) Nothing Nothing - ], - recommended = [], - optional = [] - }, - allowUnknownTypes = True, - types = [] - } - assertEqual - (Left (ConditionFieldNotDeclared Nothing (nestedDefinitionTestPath "reviews" "provider") (nestedDefinitionTestPath "reviews" "status") :| [])) - (compileProfile crossScopeProfile) - where - nestedDefinitionTestPath parent child = - FieldPath (FieldName parent :| [FieldName child]) - -testTopLevelConditionalPresence :: Either Text () -testTopLevelConditionalPresence = do - let statusRule = FieldRule "status" Nothing ["active", "superseded"] Scalar Nothing Nothing Nothing Nothing - recommendedTarget = - FieldRule "supersededBy" Nothing ["ADR-1"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["active"])) - requiredTarget = - FieldRule "supersededBy" Nothing ["ADR-1"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["superseded"])) - base = - typeAwareProfileSpec - { frontmatter = FrontmatterRules {required = [requiredField "type", statusRule], recommended = [recommendedTarget], optional = []}, - allowUnknownTypes = True, - types = - [ withTypeFrontmatter - FrontmatterRules {required = [requiredTarget], recommended = [], optional = []} - (firstTypeRule typeAwareProfileSpec) - ] - } - compiled <- firstShow (compileProfile base) - active <- profileConcept "active" [("type", String "Owned Concept"), ("status", String "active")] "# Active\n" - superseded <- profileConcept "superseded" [("type", String "Owned Concept"), ("status", String "superseded")] "# Superseded\n" - invalidPresent <- profileConcept "invalid-present" [("type", String "Owned Concept"), ("status", String "active"), ("supersededBy", String "ADR-2")] "# Invalid\n" - missingSource <- profileConcept "missing-source" [("type", String "Owned Concept")] "# Missing source\n" - invalidSource <- profileConcept "invalid-source" [("type", String "Owned Concept"), ("status", String "unknown")] "# Invalid source\n" - wrongShapeSource <- profileConcept "wrong-shape-source" [("type", String "Owned Concept"), ("status", toJSON (["active"] :: [Text]))] "# Wrong shape\n" - activeId <- parseTestConceptId "active" - supersededId <- parseTestConceptId "superseded" - invalidId <- parseTestConceptId "invalid-present" - missingSourceId <- parseTestConceptId "missing-source" - invalidSourceId <- parseTestConceptId "invalid-source" - wrongShapeSourceId <- parseTestConceptId "wrong-shape-source" - assertEqual [] (validateProfile PermissiveConformance compiled [active]) - assertEqual - [MissingRecommendedProfileField activeId "supersededBy" (Just (FieldCondition "status" ["active"]))] - (validateProfile StrictAuthoring compiled [active]) - assertEqual - [MissingProfileField supersededId "supersededBy" (Just (FieldCondition "status" ["superseded"]))] - (validateProfile PermissiveConformance compiled [superseded]) - assertEqual - [ValueNotInVocabulary invalidId (fieldPath "supersededBy") ["ADR-1"] (String "ADR-2")] - (validateProfile PermissiveConformance compiled [invalidPresent]) - assertEqual - [MissingProfileField missingSourceId "status" Nothing] - (validateProfile PermissiveConformance compiled [missingSource]) - assertEqual - [ValueNotInVocabulary invalidSourceId (fieldPath "status") ["active", "superseded"] (String "unknown")] - (validateProfile PermissiveConformance compiled [invalidSource]) - assertEqual - [CardinalityMismatch wrongShapeSourceId (fieldPath "status") Scalar (toJSON (["active"] :: [Text]))] - (validateProfile PermissiveConformance compiled [wrongShapeSource]) - -testNestedConditionalPresence :: Either Text () -testNestedConditionalPresence = do - let nestedRules = - NestedRules - { required = - [ NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing, - NestedFieldRule "provider" Nothing [] Scalar Nothing (Just (FieldCondition "kind" ["model"])) - ], - recommended = - [NestedFieldRule "notes" Nothing [] Scalar Nothing (Just (FieldCondition "kind" ["human"]))], - optional = [] - } - spec = nestedProfileWithRules List nestedRules Nothing - compiled <- firstShow (compileProfile spec) - concept <- - profileConcept - "conditional-reviews" - [ ("type", String "Reviewed Concept"), - ("reviews", toJSON [object ["kind" .= ("model" :: Text)], object ["kind" .= ("human" :: Text)], object []]) - ] - "# Conditional reviews\n" - cid <- parseTestConceptId "conditional-reviews" - assertEqual - [MissingNestedProfileField cid (nestedTestPath 0 "provider") (Just (FieldCondition "kind" ["model"])), MissingNestedProfileField cid (nestedTestPath 2 "kind") Nothing] - (validateProfile PermissiveConformance compiled [concept]) - assertEqual - [ MissingNestedProfileField cid (nestedTestPath 0 "provider") (Just (FieldCondition "kind" ["model"])), - MissingRecommendedNestedProfileField cid (nestedTestPath 1 "notes") (Just (FieldCondition "kind" ["human"])), - MissingNestedProfileField cid (nestedTestPath 2 "kind") Nothing - ] - (validateProfile StrictAuthoring compiled [concept]) - -testReferenceDefinitionErrors :: Either Text () -testReferenceDefinitionErrors = do - let referenceRule key prefix schemes fieldFormat = - FieldRule - key - Nothing - [] - Scalar - fieldFormat - Nothing - (Just (HandleReferenceRule prefix schemes False)) - Nothing - baseType = firstTypeRule testDocumentIdProfileSpec - specWith profileIdField typeRules profileRules = - testDocumentIdProfileSpec - { frontmatter = FrontmatterRules {required = profileRules, recommended = [], optional = []}, - idField = profileIdField, - types = typeRules - } - path = fieldPath "supersedes" - invalidPrefixType = baseType {idPrefix = Just "1ADR"} - invalidPrefixSpec = specWith (Just "docId") [invalidPrefixType] [referenceRule "supersedes" "1ADR" [] Nothing] - undeclaredPrefixSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "PAT" [] Nothing] - missingIdFieldSpec = specWith Nothing [baseType] [referenceRule "supersedes" "ADR" [] Nothing] - invalidSchemeSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "ADR" ["mori_", "MORI_"] Nothing] - formatSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "ADR" [] (Just (DocumentHandle "ADR"))] - typeReference = referenceRule "supersedes" "RFC" [] Nothing - conflictingType :: TypeRule - conflictingType = baseType & #frontmatter .~ FrontmatterRules {required = [typeReference], recommended = [], optional = []} - rfcType = baseType {type_ = "RFC", idPrefix = Just "RFC", pathPattern = Nothing} - conflictSpec = specWith (Just "docId") [conflictingType, rfcType] [referenceRule "supersedes" "ADR" [] Nothing] - assertEqual - (Left (InvalidReferencePrefix Nothing path "1ADR" :| [])) - (compileProfile invalidPrefixSpec) - assertEqual - (Left (ReferencePrefixNotDeclared Nothing path "PAT" :| [])) - (compileProfile undeclaredPrefixSpec) - assertEqual - (Left (ReferenceRequiresIdField Nothing path :| [])) - (compileProfile missingIdFieldSpec) - assertEqual - (Left (InvalidExternalReferenceScheme Nothing path "mori_" :| [])) - (compileProfile invalidSchemeSpec) - assertEqual - (Left (ReferenceWithFormat Nothing path (DocumentHandle "ADR") :| [])) - (compileProfile formatSpec) - assertEqual - (Left (ConflictingReferencePrefix "Decision Record" path "ADR" "RFC" :| [])) - (compileProfile conflictSpec) - -testDocumentReferenceValidation :: Either Text () -testDocumentReferenceValidation = do - let referencePolicy = HandleReferenceRule "ADR" ["mori", "MORI"] False - selfPolicy = HandleReferenceRule "ADR" [] True - referenceRules = - [ FieldRule "references" Nothing [] List Nothing Nothing (Just referencePolicy) Nothing, - FieldRule "selfReference" Nothing [] Scalar Nothing Nothing (Just selfPolicy) Nothing - ] - spec :: ProfileSpec - spec = - testDocumentIdProfileSpec - & #frontmatter - .~ FrontmatterRules - { required = [requiredField "type", requiredField "title"], - recommended = referenceRules, - optional = [] - } - compiled <- firstShow (compileProfile spec) - duplicateA <- decisionConcept "decisions/duplicate-a" "Duplicate A" "ADR-3" [] - duplicateB <- decisionConcept "decisions/duplicate-b" "Duplicate B" "ADR-3" [] - source <- - decisionConcept - "decisions/source" - "Source" - "ADR-1" - [ ( "references", - toJSON - [ String "ADR-2", - String "ADR-99", - String "PAT-3", - String "not a reference", - String "https://example.test/external", - String "MORI://shinzui/okf/docs/one", - String "ADR-1", - Number 7, - String "ADR-3" - ] - ), - ("selfReference", String "ADR-1") - ] - target <- decisionConcept "decisions/target" "Target" "ADR-2" [] - duplicateAId <- parseTestConceptId "decisions/duplicate-a" - duplicateBId <- parseTestConceptId "decisions/duplicate-b" - sourceId <- parseTestConceptId "decisions/source" - assertEqual - [ DanglingHandleReference sourceId (indexedPath "references" 1) "ADR-99", - ReferenceHandlePrefixMismatch sourceId (indexedPath "references" 2) "PAT-3" "ADR", - MalformedDocumentReference sourceId (indexedPath "references" 3) (String "not a reference"), - ExternalReferenceSchemeNotAllowed sourceId (indexedPath "references" 4) "https" ["mori"], - SelfDocumentReference sourceId (indexedPath "references" 6) "ADR-1", - MalformedDocumentReference sourceId (indexedPath "references" 7) (Number 7), - DuplicateDocumentId "ADR-3" duplicateAId duplicateBId - ] - (validateProfile PermissiveConformance compiled [target, source, duplicateB, duplicateA]) - where - decisionConcept cid title documentId extraFields = - profileConcept - cid - ([("type", String "Decision Record"), ("title", String title), ("docId", String documentId)] <> extraFields) - ("# " <> title <> "\n") - indexedPath key elementIndex = FieldPath (FieldName key :| [ArrayIndex elementIndex]) - --- | The whole point of the third presence list: absence is silent in both --- validation modes, while a present value is checked exactly as hard as it would --- be under @required@. -testOptionalFieldPresence :: Either Text () -testOptionalFieldPresence = do - let optionalRules = - [ FieldRule "supersedes" Nothing ["ADR-1", "ADR-2"] Scalar Nothing Nothing Nothing Nothing, - FieldRule "reviewedAt" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing Nothing, - FieldRule "tags" Nothing [] List Nothing Nothing Nothing Nothing - ] - spec = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [requiredField "type"], - recommended = [requiredField "owner"], - optional = optionalRules - }, - allowUnknownTypes = True, - types = [] - } - compiled <- firstShow (compileProfile spec) - absent <- profileConcept "optional/absent" [("type", String "Extension"), ("owner", String "Ari")] "# Absent\n" - -- A correctly shaped empty value counts as absent, so it is as silent as a key - -- that was never written. (A blank value on a field that also declares a - -- vocabulary or format still fails that check; presence and value are - -- independent, which is exactly what this feature relies on.) - emptied <- - profileConcept - "optional/emptied" - [ ("type", String "Extension"), - ("owner", String "Ari"), - ("tags", toJSON ([] :: [Text])) - ] - "# Emptied\n" - valid <- - profileConcept - "optional/valid" - [ ("type", String "Extension"), - ("owner", String "Ari"), - ("supersedes", String "ADR-1"), - ("reviewedAt", String "2026-07-30T00:00:00Z"), - ("tags", toJSON (["profiles"] :: [Text])) - ] - "# Valid\n" - invalid <- - profileConcept - "optional/invalid" - [ ("type", String "Extension"), - ("owner", String "Ari"), - ("supersedes", String "ADR-9"), - ("reviewedAt", String "2026-13-45T99:99:99Z"), - ("tags", String "profiles") - ] - "# Invalid\n" - invalidId <- parseTestConceptId "optional/invalid" - for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> do - assertEqual [] (validateProfile validationProfile compiled [absent]) - assertEqual [] (validateProfile validationProfile compiled [emptied]) - assertEqual [] (validateProfile validationProfile compiled [valid]) - assertEqual - [ ValueFormatMismatch invalidId (fieldPath "reviewedAt") Rfc3339Utc (String "2026-13-45T99:99:99Z"), - ValueNotInVocabulary invalidId (fieldPath "supersedes") ["ADR-1", "ADR-2"] (String "ADR-9"), - CardinalityMismatch invalidId (fieldPath "tags") List (String "profiles") - ] - (validateProfile validationProfile compiled [invalid]) - --- | An optional field carrying a document-reference policy resolves handles the --- same way a required one does; only the absence check differs. -testOptionalReferenceValidation :: Either Text () -testOptionalReferenceValidation = do - let spec :: ProfileSpec - spec = - testDocumentIdProfileSpec - & #frontmatter - .~ FrontmatterRules - { required = [requiredField "type", requiredField "title"], - recommended = [], - optional = [FieldRule "supersedes" Nothing [] Scalar Nothing Nothing (Just (HandleReferenceRule "ADR" [] False)) Nothing] - } - compiled <- firstShow (compileProfile spec) - target <- decisionTestConcept "decisions/target" "Target" "ADR-1" [] - silent <- decisionTestConcept "decisions/silent" "Silent" "ADR-2" [] - dangling <- decisionTestConcept "decisions/dangling" "Dangling" "ADR-3" [("supersedes", String "ADR-99")] - danglingId <- parseTestConceptId "decisions/dangling" - for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> do - assertEqual [] (validateProfile validationProfile compiled [target, silent]) - assertEqual - [DanglingHandleReference danglingId (fieldPath "supersedes") "ADR-99"] - (validateProfile validationProfile compiled [target, dangling]) - --- | Optional members of a list-element record behave the same way inside every --- record: never missing, always checked when present. -testOptionalNestedFieldPresence :: Either Text () -testOptionalNestedFieldPresence = do - let nestedRules = - NestedRules - { required = [NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing], - recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing], - optional = [NestedFieldRule "model" Nothing ["opus", "sonnet"] Scalar Nothing Nothing] - } - compiled <- firstShow (compileProfile (nestedProfileWithRules Any nestedRules Nothing)) - concept <- - profileConcept - "reviewed/optional" - [ ("type", String "Reviewed Concept"), - ( "reviews", - toJSON - [ object ["kind" .= ("human" :: Text), "notes" .= ("looks good" :: Text)], - object ["kind" .= ("model" :: Text), "notes" .= ("ran it" :: Text), "model" .= ("opus" :: Text)], - object ["kind" .= ("model" :: Text), "notes" .= ("ran it" :: Text), "model" .= ("gpt" :: Text)] - ] - ) - ] - "# Optional\n" - cid <- parseTestConceptId "reviewed/optional" - for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> - assertEqual - [ValueNotInVocabulary cid (nestedTestPath 2 "model") ["opus", "sonnet"] (String "gpt")] - (validateProfile validationProfile compiled [concept]) - --- | An optional key is declared for the purposes of field-name closure, so a --- closed profile accepts it and still catches a misspelling of it. -testOptionalFieldClosure :: Either Text () -testOptionalFieldClosure = do - let closed = - typeAwareProfileSpec - { frontmatter = - FrontmatterRules - { required = [requiredField "type"], - recommended = [], - optional = [requiredField "supersedes"] - }, - allowUnknownTypes = True, - allowUnknownFields = False, - types = [] - } - compiled <- firstShow (compileProfile closed) - declared <- profileConcept "closed/declared" [("type", String "Extension"), ("supersedes", String "ADR-1")] "# Declared\n" - typo <- profileConcept "closed/typo" [("type", String "Extension"), ("supersedse", String "ADR-1")] "# Typo\n" - typoId <- parseTestConceptId "closed/typo" - assertEqual [] (validateProfile PermissiveConformance compiled [declared]) - assertEqual - [FieldNotInProfile typoId "supersedse"] - (validateProfile PermissiveConformance compiled [typo]) - --- | Declaring a key optional at one scope does not cancel the other scope's --- presence clause. Merging accumulates clauses precisely so a type rule can --- narrow but never silently weaken a profile-wide expectation. -testOptionalDoesNotCancelOtherScope :: Either Text () -testOptionalDoesNotCancelOtherScope = do - let ownerRule = requiredField "owner" - specWith profileRules typeRules = - typeAwareProfileSpec - { frontmatter = profileRules, - allowUnknownTypes = True, - types = [withTypeFrontmatter typeRules (firstTypeRule typeAwareProfileSpec)] - } - recommendedThenOptional = - specWith - FrontmatterRules {required = [requiredField "type"], recommended = [ownerRule], optional = []} - FrontmatterRules {required = [], recommended = [], optional = [ownerRule]} - optionalThenRecommended = - specWith - FrontmatterRules {required = [requiredField "type"], recommended = [], optional = [ownerRule]} - FrontmatterRules {required = [], recommended = [ownerRule], optional = []} - concept <- profileConcept "owned/one" [("type", String "Owned Concept")] "# One\n" - cid <- parseTestConceptId "owned/one" - for_ [recommendedThenOptional, optionalThenRecommended] $ \spec -> do - compiled <- firstShow (compileProfile spec) - assertEqual [] (validateProfile PermissiveConformance compiled [concept]) - assertEqual - [MissingRecommendedProfileField cid "owner" Nothing] - (validateProfile StrictAuthoring compiled [concept]) - --- | Compilation rejects the two contradictions the third list makes possible: a --- key classified twice at one scope, and a condition on a rule that has no --- presence check for it to gate. -testOptionalDefinitionErrors :: Either Text () -testOptionalDefinitionErrors = do - let key name = requiredField name - specWith rules = - typeAwareProfileSpec {frontmatter = rules, allowUnknownTypes = True, types = []} - conditioned name sourceKey = - FieldRule name Nothing [] Any Nothing Nothing Nothing (Just (FieldCondition sourceKey ["active"])) - statusRule = FieldRule "status" Nothing ["active"] Scalar Nothing Nothing Nothing Nothing - assertEqual - (Left (ConflictingFieldRequirement Nothing "owner" :| [])) - (compileProfile (specWith FrontmatterRules {required = [key "type", key "owner"], recommended = [], optional = [key "owner"]})) - assertEqual - (Left (ConflictingFieldRequirement Nothing "owner" :| [])) - (compileProfile (specWith FrontmatterRules {required = [key "type"], recommended = [key "owner"], optional = [key "owner"]})) - assertEqual - (Left (DuplicateFieldRule Nothing "optional" "owner" :| [])) - (compileProfile (specWith FrontmatterRules {required = [key "type"], recommended = [], optional = [key "owner", key "owner"]})) - assertEqual - (Left (OptionalFieldWithCondition Nothing (fieldPath "supersededBy") :| [])) - ( compileProfile - (specWith FrontmatterRules {required = [key "type", statusRule], recommended = [], optional = [conditioned "supersededBy" "status"]}) - ) - let nestedRules = - NestedRules - { required = [NestedFieldRule "kind" Nothing ["model"] Scalar Nothing Nothing], - recommended = [], - optional = [NestedFieldRule "model" Nothing [] Scalar Nothing (Just (FieldCondition "kind" ["model"]))] - } - assertEqual - (Left (OptionalFieldWithCondition Nothing (FieldPath (FieldName "reviews" :| [FieldName "model"])) :| [])) - (compileProfile (nestedProfileWithRules Any nestedRules Nothing)) - let optionalParent = - specWith - FrontmatterRules - { required = [key "type"], - recommended = [], - optional = [FieldRule "reviews" Nothing [] List Nothing (Just nestedRules) Nothing Nothing] - } - assertEqual - (Left (OptionalFieldWithCondition Nothing (FieldPath (FieldName "reviews" :| [FieldName "model"])) :| [])) - (compileProfile optionalParent) - -decisionTestConcept :: Text -> Text -> Text -> [(Text, Value)] -> Either Text Concept -decisionTestConcept cid title documentId extraFields = - profileConcept - cid - ([("type", String "Decision Record"), ("title", String title), ("docId", String documentId)] <> extraFields) - ("# " <> title <> "\n") - --- | The end-to-end proof, run against the fixture bundle a reader can also run --- from the command line. Absence of the three optional keys is silent in both --- modes; the one genuine recommendation still fails under strict authoring; the --- conditional requirement in the same type still fires; and every optional key --- that /is/ present is checked as hard as a required one. -testOptionalFieldsFixture :: IO (Either Text ()) -testOptionalFieldsFixture = do - descriptorPath <- fixtureFilePath "profiles/optional-fields.dhall" - conditionPath <- fixtureFilePath "profiles/optional-conditional-invalid.dhall" - collisionPath <- fixtureFilePath "profiles/optional-collision-invalid.dhall" - loaded <- loadProfileFile descriptorPath - conditionLoaded <- loadProfileFile conditionPath - collisionLoaded <- loadProfileFile collisionPath - root <- fixturePath "profile-optional-fields" - concepts <- readBundle root - pure $ do - spec <- first ("failed to load optional-fields profile: " <>) loaded - compiled <- firstShow (compileProfile spec) - conditionSpec <- first ("failed to load invalid optional-condition profile: " <>) conditionLoaded - collisionSpec <- first ("failed to load invalid optional-collision profile: " <>) collisionLoaded - assertEqual - ( Left - ( OptionalFieldWithCondition (Just "Decision Record") (FieldPath (FieldName "reviews" :| [FieldName "model"])) - :| [OptionalFieldWithCondition (Just "Decision Record") (fieldPath "supersededBy")] - ) - ) - (compileProfile conditionSpec) - assertEqual - ( Left - ( ConflictingFieldRequirement Nothing "reviewedBy" - :| [ConflictingFieldRequirement (Just "Decision Record") "owner"] - ) - ) - (compileProfile collisionSpec) - accepted <- parseTestConceptId "decisions/accepted" - badSupersedes <- parseTestConceptId "decisions/bad-supersedes" - superseded <- parseTestConceptId "decisions/superseded" - let valueViolations = - [ ValueFormatMismatch badSupersedes (fieldPath "decidedAt") Rfc3339Utc (String "not a timestamp"), - ValueNotInVocabulary badSupersedes (nestedReviewPath 0 "model") ["opus", "sonnet"] (String "gpt"), - DanglingHandleReference badSupersedes (fieldPath "supersedes") "ADR-99", - MissingProfileField superseded "supersededBy" (Just (FieldCondition "status" ["superseded"])) - ] - assertEqual valueViolations (validateProfile PermissiveConformance compiled concepts) - assertEqual - (MissingRecommendedProfileField accepted "reviewedBy" Nothing : valueViolations) - (validateProfile StrictAuthoring compiled concepts) - where - nestedReviewPath elementIndex key = - FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) - -testClosedFieldValidation :: Either Text () -testClosedFieldValidation = do - let ownedRule :: TypeRule - ownedRule = - withTypeFrontmatter - FrontmatterRules {required = [requiredField "owner"], recommended = [], optional = []} - (firstTypeRule typeAwareProfileSpec) - reviewRule = - withTypeName - "Review" - (withTypeFrontmatter FrontmatterRules {required = [requiredField "reviewer"], recommended = [], optional = []} ownedRule) - closed = - typeAwareProfileSpec - { frontmatter = FrontmatterRules {required = [requiredField "type", requiredField "status"], recommended = [], optional = []}, - allowUnknownFields = False, - idField = Just "requestId", - types = [ownedRule, reviewRule] - } - compiled <- firstShow (compileProfile closed) - typo <- - profileConcept - "owned/typo" - [ ("type", String "Owned Concept"), - ("title", String "Typo"), - ("description", String "Core"), - ("timestamp", String "2026-07-29T00:00:00Z"), - ("resource", String "https://example.test/typo"), - ("tags", toJSON (["profiles"] :: [Text])), - ("requestId", String "IR-1"), - ("owner", String "Ari"), - ("reviewer", String "Bo"), - ("stauts", String "draft") - ] - "# Typo\n" - cid <- parseTestConceptId "owned/typo" - assertEqual - [ MissingProfileField cid "status" Nothing, - FieldNotInProfile cid "reviewer", - FieldNotInProfile cid "stauts" - ] - (validateProfile PermissiveConformance compiled [typo]) - let reopened = closed {allowUnknownFields = True} - reopenedCompiled <- firstShow (compileProfile reopened) - assertEqual - [MissingProfileField cid "status" Nothing] - (validateProfile PermissiveConformance reopenedCompiled [typo]) - -firstTypeRule :: ProfileSpec -> TypeRule -firstTypeRule spec = - case spec ^. #types of - rule : _ -> rule - [] -> error "test profile unexpectedly has no type rules" - -withTypeFrontmatter :: FrontmatterRules -> TypeRule -> TypeRule -withTypeFrontmatter - replacement - TypeRule - { type_, - description, - pathPattern, - resourceScheme, - requireSchemaSection, - schemaColumns, - idPrefix - } = - TypeRule - { type_, - description, - frontmatter = replacement, - pathPattern, - resourceScheme, - requireSchemaSection, - schemaColumns, - idPrefix - } - -withTypeName :: Text -> TypeRule -> TypeRule -withTypeName - replacement - TypeRule - { description, - frontmatter, - pathPattern, - resourceScheme, - requireSchemaSection, - schemaColumns, - idPrefix - } = - TypeRule - { type_ = replacement, - description, - frontmatter, - pathPattern, - resourceScheme, - requireSchemaSection, - schemaColumns, - idPrefix - } - -testProfileRulesApplyToUnknownTypes :: Either Text () -testProfileRulesApplyToUnknownTypes = do - compiled <- firstShow (compileProfile typeAwareProfileSpec) - concept <- profileConcept "extensions/one" [("type", String "Extension Concept")] "# One\n" - cid <- parseTestConceptId "extensions/one" - assertEqual - [MissingProfileField cid "title" Nothing] - (validateProfile PermissiveConformance compiled [concept]) - -testStrictProfileRecommendations :: Either Text () -testStrictProfileRecommendations = do - compiled <- firstShow (compileProfile typeAwareProfileSpec) - concept <- - profileConcept - "owned/one" - [("type", String "Owned Concept"), ("title", String "One"), ("owner", String "Ari")] - "# One\n" - cid <- parseTestConceptId "owned/one" - assertEqual [] (validateProfile PermissiveConformance compiled [concept]) - assertEqual - [MissingRecommendedProfileField cid "reviewer" Nothing] - (validateProfile StrictAuthoring compiled [concept]) - --- | Build an in-memory concept from a raw ID, frontmatter pairs, and a body. -profileConcept :: Text -> [(Text, Value)] -> Text -> Either Text Concept -profileConcept rawId fieldPairs bodyText = do - conceptId <- parseTestConceptId rawId - pure (conceptFromDocument conceptId (OKFDocument (frontmatterFromFields fieldPairs) bodyText)) - --- | A well-formed @# Schema@ section matching the profile's required columns. -schemaSectionBody :: Text -schemaSectionBody = - Text.unlines - [ "# Schema", - "", - "| Column | Type | Nullable | Description |", - "|--------|--------|----------|-------------|", - "| id | bigint | no | Primary key |" - ] - -testProfileConformingTable :: Either Text () -testProfileConformingTable = do - concept <- - profileConcept - "schemas/sales/tables/orders" - [ ("type", String "PostgreSQL Table"), - ("title", String "Orders"), - ("resource", String "postgresql://warehouse/sales/orders") - ] - schemaSectionBody - assertEqual [] (validateTestProfile testProfileSpec [concept]) - -testProfileUnknownType :: Either Text () -testProfileUnknownType = do - concept <- - profileConcept - "schemas/sales/tables/bad" - [("type", String "pg table"), ("resource", String "postgresql://x")] - schemaSectionBody - cid <- parseTestConceptId "schemas/sales/tables/bad" - assertEqual - [TypeNotInProfile cid "pg table", MissingProfileField cid "title" Nothing] - (validateTestProfile testProfileSpec [concept]) - -testProfileMissingField :: Either Text () -testProfileMissingField = do - concept <- - profileConcept - "schemas/sales/tables/orders" - [("type", String "PostgreSQL Table"), ("resource", String "postgresql://x")] - schemaSectionBody - cid <- parseTestConceptId "schemas/sales/tables/orders" - assertEqual [MissingProfileField cid "title" Nothing] (validateTestProfile testProfileSpec [concept]) - -testProfileResourceMismatch :: Either Text () -testProfileResourceMismatch = do - concept <- - profileConcept - "schemas/sales/tables/orders" - [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "mysql://x")] - schemaSectionBody - cid <- parseTestConceptId "schemas/sales/tables/orders" - assertEqual - [ResourceSchemeMismatch cid "postgresql" "mysql://x"] - (validateTestProfile testProfileSpec [concept]) - -testProfilePathMismatch :: Either Text () -testProfilePathMismatch = do - concept <- - profileConcept - "tables/orders" - [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] - schemaSectionBody - cid <- parseTestConceptId "tables/orders" - assertEqual - [PathPatternMismatch cid "PostgreSQL Table" "schemas/*/tables/*"] - (validateTestProfile testProfileSpec [concept]) - -testProfileMissingSchema :: Either Text () -testProfileMissingSchema = do - concept <- - profileConcept - "schemas/sales/tables/orders" - [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] - "# Overview\n\nNo schema section here.\n" - cid <- parseTestConceptId "schemas/sales/tables/orders" - assertEqual - [MissingSchemaSection cid "PostgreSQL Table"] - (validateTestProfile testProfileSpec [concept]) - -testProfileSchemaColumnsMismatch :: Either Text () -testProfileSchemaColumnsMismatch = do - let mismatchBody = - Text.unlines - ["# Schema", "", "| Col | Type |", "|-----|------|", "| id | bigint |"] - concept <- - profileConcept - "schemas/sales/tables/orders" - [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] - mismatchBody - cid <- parseTestConceptId "schemas/sales/tables/orders" - assertEqual - [SchemaColumnsMismatch cid "PostgreSQL Table" ["Column", "Type", "Nullable", "Description"] ["Col", "Type"]] - (validateTestProfile testProfileSpec [concept]) - -testProfileConformingDocumentId :: Either Text () -testProfileConformingDocumentId = do - concept <- - profileConcept - "decisions/one" - [("type", String "Decision Record"), ("title", String "One"), ("docId", String "ADR-1")] - "# One\n" - assertEqual [] (validateTestProfile testDocumentIdProfileSpec [concept]) - -testProfileMissingDocumentId :: Either Text () -testProfileMissingDocumentId = do - concept <- - profileConcept - "decisions/one" - [("type", String "Decision Record"), ("title", String "One")] - "# One\n" - cid <- parseTestConceptId "decisions/one" - assertEqual - [MissingDocumentId cid "Decision Record" "ADR"] - (validateTestProfile testDocumentIdProfileSpec [concept]) - -testProfileMalformedDocumentIds :: Either Text () -testProfileMalformedDocumentIds = do - leadingZero <- - profileConcept - "decisions/leading-zero" - [("type", String "Decision Record"), ("title", String "Leading zero"), ("docId", String "ADR-007")] - "# Leading zero\n" - wrongPrefix <- - profileConcept - "decisions/wrong-prefix" - [("type", String "Decision Record"), ("title", String "Wrong prefix"), ("docId", String "RFC-1")] - "# Wrong prefix\n" - leadingZeroId <- parseTestConceptId "decisions/leading-zero" - wrongPrefixId <- parseTestConceptId "decisions/wrong-prefix" - assertEqual - [ MalformedDocumentId leadingZeroId "ADR" "ADR-007", - MalformedDocumentId wrongPrefixId "ADR" "RFC-1" - ] - (validateTestProfile testDocumentIdProfileSpec [leadingZero, wrongPrefix]) - -testProfileDuplicateDocumentIds :: Either Text () -testProfileDuplicateDocumentIds = do - second <- - profileConcept - "decisions/second" - [("type", String "Decision Record"), ("title", String "Second"), ("docId", String "ADR-1")] - "# Second\n" - firstConcept <- - profileConcept - "decisions/first" - [("type", String "Decision Record"), ("title", String "First"), ("docId", String "ADR-1")] - "# First\n" - firstId <- parseTestConceptId "decisions/first" - secondId <- parseTestConceptId "decisions/second" - assertEqual - [DuplicateDocumentId "ADR-1" firstId secondId] - (validateTestProfile testDocumentIdProfileSpec [second, firstConcept]) - -testProfileDocumentIdsOffByDefault :: Either Text () -testProfileDocumentIdsOffByDefault = do - concept <- - profileConcept - "schemas/sales/tables/orders" - [ ("type", String "PostgreSQL Table"), - ("title", String "Orders"), - ("resource", String "postgresql://warehouse/sales/orders"), - ("docId", String "not-a-handle") - ] - schemaSectionBody - assertEqual [] (validateTestProfile testProfileSpec [concept]) - -testSchemaSectionColumns :: Either Text () -testSchemaSectionColumns = - assertEqual - (Just ["Column", "Type", "Nullable", "Description"]) - (schemaSectionColumns schemaSectionBody) - --- | Milestone 5: walking the deviating fixture and validating it against the --- shipped descriptor produces exactly the expected advisory deviations. -testProfileDeviationsFixture :: IO (Either Text ()) -testProfileDeviationsFixture = do - descriptorPath <- fixtureFilePath "profiles/postgresql.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-deviations" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load profile: " <> err) - Right spec -> do - badId <- parseTestConceptId "schemas/sales/tables/bad" - ordersId <- parseTestConceptId "schemas/sales/tables/orders" - assertEqual - [TypeNotInProfile badId "pg table", MissingProfileField ordersId "title" Nothing] - (validateTestProfile spec concepts) - -testDocumentIdDeviationsFixture :: IO (Either Text ()) -testDocumentIdDeviationsFixture = do - descriptorPath <- fixtureFilePath "profiles/decisions.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "doc-id-deviations" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load document ID profile: " <> err) - Right spec -> do - firstId <- parseTestConceptId "decisions/first" - secondId <- parseTestConceptId "decisions/second" - thirdId <- parseTestConceptId "decisions/third" - fourthId <- parseTestConceptId "decisions/fourth" - assertEqual - [ MissingDocumentId fourthId "Decision Record" "ADR", - MalformedDocumentId thirdId "ADR" "ADR-007", - DuplicateDocumentId "ADR-1" firstId secondId - ] - (validateTestProfile spec concepts) - -testTypeAwareProfileFixture :: IO (Either Text ()) -testTypeAwareProfileFixture = do - descriptorPath <- fixtureFilePath "profiles/type-frontmatter.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-type-frontmatter" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load type-aware profile: " <> err) - Right spec -> do - compiled <- firstShow (compileProfile spec) - ownedId <- parseTestConceptId "owned" - assertEqual [] (validateProfile PermissiveConformance compiled concepts) - assertEqual - [MissingRecommendedProfileField ownedId "reviewer" Nothing] - (validateProfile StrictAuthoring compiled concepts) - -testClosedFieldsFixture :: IO (Either Text ()) -testClosedFieldsFixture = do - descriptorPath <- fixtureFilePath "profiles/closed-fields.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-closed-fields" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load closed-field profile: " <> err) - Right spec -> do - compiled <- firstShow (compileProfile spec) - typoId <- parseTestConceptId "requests/typo" - assertEqual - [MissingProfileField typoId "status" Nothing, FieldNotInProfile typoId "stauts"] - (validateProfile PermissiveConformance compiled concepts) - -testCardinalityFixture :: IO (Either Text ()) -testCardinalityFixture = do - descriptorPath <- fixtureFilePath "profiles/cardinality.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-cardinality" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load cardinality profile: " <> err) - Right spec -> do - compiled <- firstShow (compileProfile spec) - badId <- parseTestConceptId "bad" - assertEqual - [ CardinalityMismatch badId (fieldPath "tags") List (String "one"), - CardinalityMismatch badId (fieldPath "title") Scalar (toJSON (["One", "Two"] :: [Text])) - ] - (validateProfile PermissiveConformance compiled concepts) - -testFormatsFixture :: IO (Either Text ()) -testFormatsFixture = do - descriptorPath <- fixtureFilePath "profiles/formats.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-formats" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load format profile: " <> err) - Right spec -> do - compiled <- firstShow (compileProfile spec) - badId <- parseTestConceptId "bad" - assertEqual - [ ValueFormatMismatch badId (fieldPath "docId") (DocumentHandle "ADR") (String "ADR-007"), - ValueFormatMismatch badId (fieldPath "homepage") (UriWithScheme "https") (String "mailto:owner@example.test"), - ValueFormatMismatch badId (fieldPath "links") Uri (toJSON (["https://example.test/good", "https://example.test/bad%ZZ"] :: [Text])), - ValueFormatMismatch badId (fieldPath "published") Date (String "2026-13-45"), - ValueFormatMismatch badId (fieldPath "timestamp") Rfc3339Utc (String "2026-07-29T17:00:00+01:00") - ] - (validateProfile PermissiveConformance compiled concepts) - -testNestedReviewsFixture :: IO (Either Text ()) -testNestedReviewsFixture = do - descriptorPath <- fixtureFilePath "profiles/nested-reviews.dhall" - loaded <- loadProfileFile descriptorPath - root <- fixturePath "profile-nested-reviews" - concepts <- readBundle root - pure $ case loaded of - Left err -> Left ("failed to load nested review profile: " <> err) - Right spec -> do - compiled <- firstShow (compileProfile spec) - badId <- parseTestConceptId "bad" - let permissiveExpected = - [ NestedElementNotRecord badId (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), - CardinalityMismatch badId (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), - MissingNestedProfileField badId (nestedTestPath 2 "outcome") Nothing, - ValueFormatMismatch badId (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), - ValueNotInVocabulary badId (nestedTestPath 2 "scope") reviewScopes (String "invalid") - ] - assertEqual permissiveExpected (validateProfile PermissiveConformance compiled concepts) - assertEqual - [ NestedElementNotRecord badId (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), - CardinalityMismatch badId (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), - MissingRecommendedNestedProfileField badId (nestedTestPath 2 "notes") Nothing, - MissingNestedProfileField badId (nestedTestPath 2 "outcome") Nothing, - ValueFormatMismatch badId (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), - ValueNotInVocabulary badId (nestedTestPath 2 "scope") reviewScopes (String "invalid") - ] - (validateProfile StrictAuthoring compiled concepts) - -testConditionalFieldsFixture :: IO (Either Text ()) -testConditionalFieldsFixture = do - descriptorPath <- fixtureFilePath "profiles/conditional-fields.dhall" - invalidDescriptorPath <- fixtureFilePath "profiles/conditional-fields-invalid.dhall" - loaded <- loadProfileFile descriptorPath - invalidLoaded <- loadProfileFile invalidDescriptorPath - root <- fixturePath "profile-conditions" - concepts <- readBundle root - pure $ do - spec <- first ("failed to load conditional profile: " <>) loaded - compiled <- firstShow (compileProfile spec) - invalidSpec <- first ("failed to load invalid conditional profile: " <>) invalidLoaded - decisionsMissingStatus <- parseTestConceptId "decisions/missing-status" - decisionsSuperseded <- parseTestConceptId "decisions/superseded" - postgresqlOperational <- parseTestConceptId "postgresql/operational" - postgresqlProjection <- parseTestConceptId "postgresql/projection" - reviewsMixed <- parseTestConceptId "reviews/mixed" - assertEqual - ( Left - ( ConditionFieldHasUnreachableValues - Nothing - (fieldPath "supersededBy") - (fieldPath "status") - ["superseded"] - ["active"] - :| [] - ) - ) - (compileProfile invalidSpec) - assertEqual - [ MissingProfileField decisionsMissingStatus "status" Nothing, - MissingProfileField decisionsSuperseded "supersededBy" (Just (FieldCondition "status" ["superseded"])), - MissingProfileField postgresqlProjection "sourceQuery" (Just (FieldCondition "derivationKind" ["projection"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "effort") (Just (FieldCondition "kind" ["model"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "model") (Just (FieldCondition "kind" ["model"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "provider") (Just (FieldCondition "kind" ["model"])) - ] - (validateProfile PermissiveConformance compiled concepts) - assertEqual - [ MissingProfileField decisionsMissingStatus "status" Nothing, - MissingProfileField decisionsSuperseded "supersededBy" (Just (FieldCondition "status" ["superseded"])), - MissingRecommendedProfileField postgresqlOperational "runbook" (Just (FieldCondition "derivationKind" ["operational"])), - MissingProfileField postgresqlProjection "sourceQuery" (Just (FieldCondition "derivationKind" ["projection"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "effort") (Just (FieldCondition "kind" ["model"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "model") (Just (FieldCondition "kind" ["model"])), - MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "provider") (Just (FieldCondition "kind" ["model"])) - ] - (validateProfile StrictAuthoring compiled concepts) - where - nestedReviewPath elementIndex key = - FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) - -testDocumentReferencesFixture :: IO (Either Text ()) -testDocumentReferencesFixture = do - descriptorPath <- fixtureFilePath "profiles/document-references.dhall" - invalidDescriptorPath <- fixtureFilePath "profiles/document-references-invalid.dhall" - loaded <- loadProfileFile descriptorPath - invalidLoaded <- loadProfileFile invalidDescriptorPath - root <- fixturePath "profile-document-references" - concepts <- readBundle root - pure $ do - spec <- first ("failed to load document-reference profile: " <>) loaded - compiled <- firstShow (compileProfile spec) - invalidSpec <- first ("failed to load invalid document-reference profile: " <>) invalidLoaded - case compileProfile invalidSpec of - Left _ -> Right () - Right _ -> Left "expected invalid document-reference descriptor to fail compilation" - duplicateAId <- parseTestConceptId "decisions/duplicate-a" - duplicateBId <- parseTestConceptId "decisions/duplicate-b" - sourceId <- parseTestConceptId "decisions/source" - assertEqual - [ DanglingHandleReference sourceId (indexedPath 1) "ADR-99", - ReferenceHandlePrefixMismatch sourceId (indexedPath 2) "PAT-3" "ADR", - MalformedDocumentReference sourceId (indexedPath 3) (String "not a reference"), - ExternalReferenceSchemeNotAllowed sourceId (indexedPath 4) "https" ["mori"], - SelfDocumentReference sourceId (indexedPath 6) "ADR-1", - MalformedDocumentReference sourceId (indexedPath 7) (Number 7), - DuplicateDocumentId "ADR-3" duplicateAId duplicateBId - ] - (validateProfile PermissiveConformance compiled concepts) - where - indexedPath elementIndex = FieldPath (FieldName "references" :| [ArrayIndex elementIndex]) - -validateTestProfile :: ProfileSpec -> [Concept] -> [ProfileViolation] -validateTestProfile spec concepts = - case compileProfile spec of - Left errors -> error ("test profile failed to compile: " <> show errors) - Right compiled -> validateProfile PermissiveConformance compiled concepts - -substringIndex :: Text -> Text -> Maybe Int -substringIndex needle haystack = - let (prefix, match) = Text.breakOn needle haystack - in if Text.null match then Nothing else Just (Text.length prefix) - -strictlyIncreasing :: [Int] -> Bool -strictlyIncreasing xs = and (zipWith (<) xs (drop 1 xs)) - -sampleDocument :: Text -sampleDocument = - Text.unlines - [ "---", - "type: BigQuery Table", - "title: Users", - "description: User records.", - "timestamp: 2026-06-16T00:00:00Z", - "tags: [users]", - "---", - "", - "# Schema", - "", - "Body text." - ] - -assertEqual :: (Eq value, Show value) => value -> value -> Either Text () -assertEqual expected actual - | expected == actual = Right () - | otherwise = - Left - ( "expected " - <> Text.pack (show expected) - <> ", got " - <> Text.pack (show actual) - ) - -assertBool :: Text -> Bool -> Either Text () -assertBool _ True = Right () -assertBool label False = Left label - -firstShow :: (Show err) => Either err value -> Either Text value -firstShow = - either (Left . Text.pack . show) Right - -readBundle :: FilePath -> IO [Concept] -readBundle root = do - result <- walkBundle root - case result of - Left bundleError -> fail (show bundleError) - Right concepts -> pure concepts +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Time (fromGregorian) +import Okf.Actor +import Okf.Bundle +import Okf.ConceptId +import Okf.Discovery +import Okf.Document +import Okf.Graph +import Okf.Index +import Okf.Log +import Okf.Markdown +import Okf.Path +-- 'List' and 'Object' are 'Cardinality' constructors; aeson's same-named +-- 'Value' constructors are reached as 'Aeson.Object' and friends. +import Okf.Prelude hiding (List, Object, setField, (.=)) +-- 'HumanActor' is both an 'Okf.Actor' constructor and a 'FieldFormat' +-- alternative. This module names the actor far more often, so the format is +-- reached as 'Profile.HumanActor'. +import Okf.Profile hiding (HumanActor) +import Okf.Profile qualified as Profile +import Okf.Profile.Documentation +import Okf.Profile.Registry +import Okf.Trust +import Okf.Validation +import System.Directory + ( createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getTemporaryDirectory, + removeDirectoryRecursive, + ) +import System.Exit (exitFailure) +import System.FilePath (normalise, takeDirectory, ()) +import System.IO.Temp (createTempDirectory) +import "generic-lens" Data.Generics.Labels () + +main :: IO () +main = do + results <- + sequence + [ test "parseActor classifies the three specification section 7 shapes" testParseActorShapes, + test "renderActor inverts parseActor on every input" testActorRoundTrip, + test "parse valid document with YAML frontmatter" testParseValidDocument, + test "parse document with no frontmatter as empty-frontmatter body" testParseNoFrontmatter, + test "reject unterminated frontmatter" testRejectUnterminatedFrontmatter, + test "reject frontmatter that is not a YAML mapping" testRejectNonMappingFrontmatter, + test "validate permissive profile with only type" testPermissiveValidation, + test "validate strict profile requiring title description generated" testStrictValidation, + test "strict validation accepts generated, falls back to timestamp, reports neither" testStrictValidationGeneratedFamily, + test "validate rejects tags that are not a string list" testRejectInvalidTags, + test "round-trip preserves semantic frontmatter and body" testRoundTrip, + test "reject invalid concept id segment" testRejectInvalidConceptId, + test "convert concept id tables/users to tables/users.md" testConceptIdToFilePath, + testIO "walkBundle reports a structured IO error for a missing root" testWalkBundleMissingRoot, + testIO "walkBundle skips index.md and log.md" testWalkBundleSkipsReserved, + testIO "walkBundle discovers nested concept IDs" testWalkBundleDiscoversNestedConceptIds, + testIO "walkBundleInventory sees a non-Markdown file that is not a concept" testWalkBundleInventorySeesNonMarkdown, + testIO "discoverBundleRoots finds a directory holding index.md" testDiscoverIndexMd, + testIO "discoverBundleRoots finds a directory holding a typed concept" testDiscoverTypedConcept, + testIO "discoverBundleRoots ignores markdown without a type field" testDiscoverIgnoresPlainMarkdown, + testIO "discoverBundleRoots does not descend into a bundle it found" testDiscoverPrunesNestedBundles, + testIO "discoverBundleRoots skips hidden and build directories" testDiscoverSkipsNoise, + testIO "discoverBundleRoots honours maxDepth" testDiscoverHonoursMaxDepth, + testIO "discoverBundleRoots reports a fixture bundle as its own root" testDiscoverFixtureBundle, + test "parseLog/serializeLog round-trips a canonical log" testLogRoundTrip, + test "validateLog flags a non-ISO date heading" testValidateLogNonIsoDate, + test "validateLog flags an empty date group" testValidateLogEmptyDay, + test "validateLog flags out-of-order days" testValidateLogOutOfOrder, + testIO "walkLogs discovers nested log.md files" testWalkLogsDiscoversNested, + test "logStaleness flags a concept newer than its nearest log" testLogStalenessFlagsNewerConcept, + test "logStaleness reads generated.at ahead of the legacy timestamp" testLogStalenessReadsGeneratedAt, + test "logStaleness prefers the deepest enclosing log" testLogStalenessPrefersDeepestLog, + test "appendLogEntry inserts newest-first and prepends within a day" testAppendLogEntry, + testIO "generateIndex groups documents by frontmatter type" testGenerateIndexGroupsByType, + testIO "extractLinks resolves relative and absolute bundle links" testExtractLinksResolveBundleLinks, + testIO "extractLinks ignores external markdown URLs" testExtractLinksIgnoresExternalUrls, + testIO "buildGraph includes only edges to existing concepts" testBuildGraphIncludesKnownEdges, + testIO "writeBundleIndexes is deterministic" testWriteBundleIndexesDeterministic, + testIO "readBundleVersion reads a declared, absent, or unparseable okf_version" testReadBundleVersion, + testIO "readBundleVersion accepts the unquoted YAML number form" testReadBundleVersionUnquoted, + testIO "writeBundleIndexes preserves an existing okf_version declaration" testWriteBundleIndexesPreservesVersion, + testIO "writeBundleIndexesWith declares a version and leaves others alone" testWriteBundleIndexesDeclaresVersion, + testIO "fixture valid bundle validates and graphs expected edges" testFixtureValidBundle, + testIO "fixture v01 legacy bundle validates strictly through the fallback" testFixtureV01LegacyBundle, + testIO "fixture graph JSON shape is stable" testFixtureGraphJsonShape, + testIO "fixture unterminated frontmatter reports parse error" testFixtureUnterminatedFrontmatter, + testIO "fixture missing type reports validation error" testFixtureMissingType, + test "frontmatter builder round-trips through serialize and parse" testFrontmatterBuilderRoundTrip, + test "serializeDocument emits deterministic key order" testSerializeDeterministicKeyOrder, + test "serializeDocument orders generated before the superseded timestamp" testSerializeGeneratedBeforeTimestamp, + test "strict validation joins footnote labels to sources ids in both directions" testFootnoteAttributionJoin, + test "footnote attribution is skipped entirely when a document has no sources" testFootnoteAttributionSkippedWithoutSources, + test "footnote parsing is enabled, so a definition is not paragraph text" testFootnotesEnabled, + test "enabling footnotes leaves log parsing and link extraction unchanged" testFootnotesDoNotRegressLogsOrLinks, + test "extractFootnoteLabels ignores footnote syntax inside code" testExtractFootnoteLabelsIgnoresCode, + test "extractFootnoteLabels keeps labels the parser erases and never ordinals" testExtractFootnoteLabelsKeepsErasedLabels, + test "computationBlocks accepts both spellings and bounds its section" testComputationBlocks, + test "computationBlocks cannot see a block inside an uncited footnote definition" testComputationBlocksFootnoteHazard, + test "rendered concept link round-trips through extractConceptLinks" testConceptLinkRoundTrip, + test "over-escaping relative links do not resolve inside bundle" testRejectOverEscapingRelativeLink, + test "classifyPathReference implements the specification section 6.2 grammar" testClassifyPathReference, + test "resolvePathReference decides existence against a bundle inventory" testResolvePathReference, + test "every versioned field name is a core frontmatter field" testVersionedFieldsAreCoreFields, + test "versionGate applies specification section 12 best-effort reading" testVersionGate, + test "declared v0.2 reports a legacy timestamp that an undeclared bundle tolerates" testLegacyFieldInDeclaredV2, + test "an unreadable or unknown declaration is a strict lint, never a refusal" testVersionDeclarationLints, + test "validateBundle reports a dangling reference" testValidateBundleDanglingReference, + test "validateBundle accepts a bundle whose links all resolve" testValidateBundleAcceptsResolved, + test "validateBundle reports a dangling frontmatter path under strict only" testValidateBundleDanglingFrontmatterPath, + test "a dangling relative path names the bundle-relative spelling that resolves" testDanglingFrontmatterPathAlternative, + test "duplicateConceptIds finds repeated ids" testDuplicateConceptIds, + test "conceptFromDocument derives typed fields from frontmatter" testConceptFromDocumentDerivesFields, + test "conceptGenerated projects the v0.2 generated family" testConceptGeneratedProjection, + test "readGenerated ignores a generated mapping with no by actor" testReadGeneratedWithoutActor, + test "readVerified reads a list and normalises a bare mapping to one element" testReadVerifiedShapes, + test "setVerified always writes a list and round-trips" testVerifiedRoundTrip, + test "readStatus defaults to stable and preserves an unknown value" testReadStatus, + test "readStaleAfter reads the date verbatim" testReadStaleAfter, + test "trustTier derives the three specification section 5.3 tiers" testTrustTier, + test "latestVerification returns the newest at" testLatestVerification, + test "staleness compares inclusively against a supplied day" testStaleness, + test "readSources reads entries and skips one without resource" testReadSources, + test "usage_window applies at document scope with per-entry override" testUsageWindowOverride, + test "setSources and setUsageWindow round-trip through serialize and parse" testSourcesRoundTrip, + test "strict validation reports sources missing resource and duplicate ids" testValidateSources, + test "the attested computation contract reads from the specification worked example" testReadAttestedComputationContract, + test "a malformed contract field is not read rather than rejected" testReadAttestedComputationDegenerateShapes, + test "the specification worked example serializes byte-identically" testAttestedComputationRoundTrip, + test "readComputationSources joins the body section to the computation key" testReadComputationSources, + test "strict validation reports an Attested Computation with no runtime" testValidateAttestedComputationRuntime, + testIO "writeBundle then walkBundle round-trips" testWriteBundleRoundTrip, + testIO "fixture dangling link reports a bundle validation error" testFixtureDanglingLink, + testIO "fixture dangling frontmatter path reports exactly one strict problem" testFixtureDanglingFrontmatterPath, + testIO "fixture attested computation bundle reports one missing runtime and no path problem" testFixtureAttestedComputation, + testIO "loadProfileFile decodes the postgresql fixture" testLoadProfileFixture, + testIO "loadProfileFile decodes record-completed document ID rules" testLoadDocumentIdProfileFixture, + testIO "loadProfileFile accepts the pre-type-frontmatter described schema" testLoadDescribedProfileFixture, + testIO "loadProfileFile accepts the frozen EP-1 type-aware schema" testLoadTypeAwareCompatibilityFixture, + testIO "loadProfileFile accepts the frozen EP-2 vocabulary schema" testLoadVocabularyCompatibilityFixture, + testIO "loadProfileFile accepts the frozen EP-3 cardinality schema" testLoadCardinalityCompatibilityFixture, + testIO "loadProfileFile accepts the frozen EP-4 format schema" testLoadFormatCompatibilityFixture, + testIO "loadProfileFile decodes bounded nested review rules" testLoadNestedReviewsProfileFixture, + testIO "loadProfileFile preserves the frozen bounded-nested schema" testLoadNestedCompatibilityFixture, + testIO "loadProfileFile decodes same-scope conditions" testLoadConditionalFieldsProfileFixture, + testIO "loadProfileFile preserves the frozen condition-aware schema" testLoadConditionalCompatibilityFixture, + testIO "loadProfileFile preserves the frozen reference-aware schema" testLoadReferenceCompatibilityFixture, + testIO "every frozen generation fixture compiles, not merely decodes" testFrozenFixturesCompile, + testIO "loadProfileFile preserves the frozen pre-bundle-version schema" testLoadPreBundleVersionCompatibilityFixture, + testIO "loadProfileFile preserves the frozen pre-path schema" testLoadPrePathCompatibilityFixture, + testIO "loadProfileFile preserves the frozen five-alternative format union" testLoadPreActorCompatibilityFixture, + testIO "loadProfileFile preserves the frozen optional-presence schema" testLoadPreObjectCompatibilityFixture, + testIO "loadProfileFile still accepts an okf 0.2.x descriptor" testLoadLegacyProfileFixture, + testIO "profileFieldDescription finds required and recommended prose" testProfileFieldDescription, + testIO "profileFieldDescription finds optional prose" testOptionalFieldDescription, + testIO "profile JSON encoding emits type, not type_" testProfileJsonShape, + test "field condition JSON encoding is stable" testFieldConditionJsonShape, + test "handle reference JSON encoding is stable" testHandleReferenceJsonShape, + test "field format JSON encoding is stable" testFieldFormatJsonShape, + testIO "loadRegistry enumerates nested profiles and skips non-profiles" testRegistryEnumeratesProfiles, + testIO "loadRegistry reports a bare profile as a root entry" testRegistryRootProfile, + testIO "resolveRegistryRef prefers package.dhall inside a directory" testResolveRegistryRef, + testIO "loadRegistry reports a missing registry as Left" testRegistryLoadFailure, + test "parseDocumentId accepts only canonical handles" testParseDocumentId, + testIO "documentIdsInBundle sorts handles by prefix and number" testDocumentIdsInBundle, + test "nextDocumentId skips gaps and starts unused prefixes at one" testNextDocumentId, + testIO "findConceptsByDocumentId resolves and reports duplicate handles" testFindConceptsByDocumentId, + test "compileProfile rejects ambiguous definitions deterministically" testCompileProfileDefinitionErrors, + test "compiled rules merge profile and type requirements" testCompiledProfileMerge, + testIO "compiledProfileTypeNames preserves declaration order" testCompiledProfileTypeNames, + testIO "compiledProfileRulesForType merges profile and type scope" testCompiledProfileRulesMergeTypeScope, + testIO "compiled optional rules carry no presence clause" testCompiledProfileOptionalPresence, + test "profileDocumentationSlug normalizes free-text type names" testProfileDocumentationSlug, + test "duplicate type slugs are disambiguated positionally" testProfileDocumentationSlugCollisions, + test "profile value display names match the documented vocabulary" testProfileValueDisplayNames, + testIO "profile documentation renders a root concept" testProfileDocumentationRootConcept, + test "profile documentation renders object rules" testProfileDocumentationObjectFields, + test "profile documentation renders a required bundle version" testProfileDocumentationRequiredBundleVersion, + testIO "profile documentation renders one concept per declared type" testProfileDocumentationTypeConcept, + testIO "profile documentation renders inherited rules for a bare type" testProfileDocumentationInheritedRules, + testIO "generated profile documentation round-trips through serialize and parse" testProfileDocumentationRoundTrip, + testIO "generated profile documentation validates permissively and strictly" testProfileDocumentationValidates, + testIO "generated profile documentation carries the default generated actor" testProfileDocumentationDefaultGenerated, + testIO "generated profile documentation honours an explicit generated family" testProfileDocumentationExplicitGenerated, + testIO "generated profile documentation omits generated on request" testProfileDocumentationOmittedGenerated, + testIO "generated profile documentation has no dangling references" testProfileDocumentationLinksResolve, + testIO "generated profile documentation is byte-stable across renders" testProfileDocumentationByteStable, + testIO "generated profile documentation survives a filesystem round trip" testProfileDocumentationFilesystemRoundTrip, + test "compiled vocabularies intersect in profile declaration order" testCompiledVocabularyIntersection, + test "compileProfile rejects disjoint vocabularies" testUnsatisfiableVocabulary, + test "compiled cardinality uses Any as identity and rejects contradictions" testCompiledCardinality, + test "profile vocabularies validate strings, lists, and shapes" testVocabularyValidation, + test "profile cardinality validates all JSON shapes and presence" testCardinalityValidation, + test "cardinality suppresses redundant vocabulary shape errors" testCardinalityVocabularyInteraction, + test "compiled formats refine Uri and reject contradictions" testCompiledFieldFormats, + test "compileProfile rejects invalid format parameters" testInvalidFormatParameters, + test "named formats validate parser boundaries, lists, and shapes" testNamedFormatValidation, + test "the actor formats accept the three specification section 7 shapes" testActorFormatValidation, + test "the numeric and boolean formats reject text and non-integers" testNonTextualFormatValidation, + test "a non-textual format refines an unspecified cardinality to scalar" testNonTextualFormatRefinesCardinality, + test "actor and integer narrow across scopes" testNewFormatsNarrowAcrossScopes, + test "compiled nested rules merge and reject impossible outer cardinality" testCompiledNestedRules, + test "nested record validation reports indexed paths and strict recommendations" testNestedRecordValidation, + test "compileProfile rejects objectFields with an explicit scalar or list cardinality" testObjectFieldsRequireObjectShape, + test "compileProfile refines an object rule to object cardinality" testCompileObjectRule, + test "compileProfile normalizes a path rule at top-level and nested scope" testCompilePathRule, + test "a type-scope path rule narrows the profile-scope one" testMergePathRule, + test "compileProfile rejects incoherent path rules" testPathDefinitionErrors, + test "compileProfile rejects an unreadable or unknown-major okfVersion" testProfileVersionParsing, + test "compileProfile clamps a higher okfVersion minor to the supported one" testProfileVersionMinorClamp, + test "compileProfile rejects an unreadable requireBundleVersion" testRequiredBundleVersionParsing, + test "validateProfileVersion judges every declaration shape" testValidateProfileVersion, + test "validateProfileVersion is inert without a requirement" testValidateProfileVersionUnrequired, + test "compileProfile rejects a superseded field outside the optional list" testProfileVersionSupersededField, + test "compileProfile rejects the actor formats in a v0.1 profile" testProfileVersionActorFormat, + test "compileProfile does not judge a profile by its key names" testProfileVersionDoesNotJudgeKeyNames, + test "validateProfile checks a top-level path-valued field" testValidatePathTopLevel, + test "validateProfile checks sources[].resource with element indexes" testValidatePathNested, + test "validateProfile checks a path inside an object-valued field" testValidatePathObjectScope, + testIO "validateProfileWith resolves a non-Markdown path target" testValidateProfileWithInventory, + testIO "the documented house profile reports the section 10 contract deviations" testAttestedComputationHouseProfile, + test "compileProfile keeps a rule declaring both shapes at any cardinality" testCompileRecordOrListRule, + test "validateProfile requires a member of an object field" testValidateObjectMember, + test "validateProfile checks a bare mapping and a list against the same member rules" testValidateRecordOrList, + test "validateProfile reports an object value where only a list is declared" testValidateObjectWrongShape, + test "an object field with no member rules still requires a mapping" testValidateEmptyObjectRules, + test "compileProfile rejects invalid same-scope field conditions" testConditionDefinitionErrors, + test "top-level conditions gate presence without gating value checks" testTopLevelConditionalPresence, + test "nested conditions use siblings and avoid cascading diagnostics" testNestedConditionalPresence, + test "compileProfile rejects invalid document reference policies" testReferenceDefinitionErrors, + test "document references resolve local handles and explicit external URIs" testDocumentReferenceValidation, + test "optional fields are never missing but are fully value-checked" testOptionalFieldPresence, + test "optional reference fields resolve handles when present" testOptionalReferenceValidation, + test "optional nested fields are never missing inside records" testOptionalNestedFieldPresence, + test "optional fields count as declared under closed field names" testOptionalFieldClosure, + test "optional at one scope does not cancel the other scope's clause" testOptionalDoesNotCancelOtherScope, + test "compileProfile rejects optional collisions and dead conditions" testOptionalDefinitionErrors, + test "closed profiles reject unknown fields and isolate type fields" testClosedFieldValidation, + test "profile rules apply to unknown concept types" testProfileRulesApplyToUnknownTypes, + test "strict profile validation checks recommendations" testStrictProfileRecommendations, + test "validateProfile accepts a conforming table concept" testProfileConformingTable, + test "validateProfile flags a type not in the vocabulary" testProfileUnknownType, + test "validateProfile flags a missing required field" testProfileMissingField, + test "validateProfile flags a resource scheme mismatch" testProfileResourceMismatch, + test "validateProfile flags a path pattern mismatch" testProfilePathMismatch, + test "validateProfile flags a missing # Schema section" testProfileMissingSchema, + test "validateProfile flags mismatched # Schema columns" testProfileSchemaColumnsMismatch, + test "validateProfile accepts a conforming document ID" testProfileConformingDocumentId, + test "validateProfile flags a missing document ID" testProfileMissingDocumentId, + test "validateProfile flags malformed document IDs" testProfileMalformedDocumentIds, + test "validateProfile flags duplicate document IDs" testProfileDuplicateDocumentIds, + test "validateProfile document ID checks are off by default" testProfileDocumentIdsOffByDefault, + test "schemaSectionColumns reads the header row of the Schema table" testSchemaSectionColumns, + testIO "validateProfile reports the expected deviations for the fixture bundle" testProfileDeviationsFixture, + testIO "validateProfile reports document ID fixture deviations" testDocumentIdDeviationsFixture, + testIO "type-aware fixture is permissive but reports one strict recommendation" testTypeAwareProfileFixture, + testIO "closed-field fixture reports missing and misspelled fields" testClosedFieldsFixture, + testIO "cardinality fixture reports scalar and list mismatches" testCardinalityFixture, + testIO "format fixture reports parser-backed mismatches" testFormatsFixture, + testIO "nested review fixture validates records with indexed diagnostics" testNestedReviewsFixture, + testIO "conditional fixture covers ADR, PostgreSQL, and review scopes" testConditionalFieldsFixture, + testIO "document reference fixture covers local, external, self, and duplicate targets" testDocumentReferencesFixture, + testIO "optional-field fixture reports only the recommendation and bad values" testOptionalFieldsFixture + ] + unless (and results) exitFailure + +test :: Text -> Either Text () -> IO Bool +test name assertion = + case assertion of + Right () -> do + putStrLn ("PASS " <> Text.unpack name) + pure True + Left message -> do + putStrLn ("FAIL " <> Text.unpack name <> ": " <> Text.unpack message) + pure False + +testIO :: Text -> IO (Either Text ()) -> IO Bool +testIO name assertion = do + result <- assertion + test name result + +testParseActorShapes :: Either Text () +testParseActorShapes = do + assertEqual (HumanActor "ahormati") (parseActor "human:ahormati") + assertEqual (ProcessActor "finance-nightly") (parseActor "process:finance-nightly") + assertEqual (ProducerActor "reference_agent" "gemini-2.5-pro") (parseActor "reference_agent/gemini-2.5-pro") + assertEqual (UnclassifiedActor "something") (parseActor "something") + -- Section 7 writes the prefixes in lower case and section 5.3 makes the + -- `human:` test load-bearing, so matching is case-sensitive. + assertEqual (UnclassifiedActor "Human:ahormati") (parseActor "Human:ahormati") + assertBool "human actor is human" (isHumanActor (parseActor "human:ahormati")) + assertBool "producer actor is not human" (not (isHumanActor (parseActor "reference_agent/gemini-2.5-pro"))) + +testActorRoundTrip :: Either Text () +testActorRoundTrip = + for_ + [ "human:ahormati", + "process:finance-nightly", + "reference_agent/gemini-2.5-pro", + "something", + "Human:ahormati", + "human:", + "/version", + "producer/", + "a/b/c", + "" + ] + (\raw -> assertEqual raw (renderActor (parseActor raw))) + +testParseValidDocument :: Either Text () +testParseValidDocument = do + document <- firstShow (parseDocument sampleDocument) + assertEqual (Just (String "BigQuery Table")) (frontmatterLookup "type" (document ^. #frontmatter)) + assertEqual "# Schema\n\nBody text.\n" (body document) + +testParseNoFrontmatter :: Either Text () +testParseNoFrontmatter = do + document <- firstShow (parseDocument "# Draft\n") + assertEqual Nothing (frontmatterLookup "type" (document ^. #frontmatter)) + assertEqual "# Draft\n" (body document) + +testRejectUnterminatedFrontmatter :: Either Text () +testRejectUnterminatedFrontmatter = + assertEqual (Left UnterminatedFrontmatter) (parseDocument "---\ntype: BigQuery Table\n") + +testRejectNonMappingFrontmatter :: Either Text () +testRejectNonMappingFrontmatter = + assertEqual (Left FrontmatterNotMapping) (parseDocument "---\n- one\n- two\n---\nBody\n") + +testPermissiveValidation :: Either Text () +testPermissiveValidation = do + document <- firstShow (parseDocument "---\ntype: BigQuery Table\n---\nBody\n") + assertEqual [] (validateDocument PermissiveConformance document) + +testStrictValidation :: Either Text () +testStrictValidation = do + document <- firstShow (parseDocument "---\ntype: BigQuery Table\n---\nBody\n") + let errors = validateDocument StrictAuthoring document + assertBool "missing title" (MissingRecommendedField "title" `List.elem` errors) + assertBool "missing description" (MissingRecommendedField "description" `List.elem` errors) + assertBool "missing generated" (MissingGeneratedField `List.elem` errors) + +-- | Specification section 5.2 satisfies the "when was this last changed" +-- requirement with `generated`, and section 13.1 permits falling back to the +-- superseded v0.1 `timestamp`. Both must pass strict validation; neither +-- present must fail it, naming the v0.2 field. +testStrictValidationGeneratedFamily :: Either Text () +testStrictValidationGeneratedFamily = do + let strictErrors source = validateDocument StrictAuthoring <$> firstShow (parseDocument source) + preamble = "---\ntype: BigQuery Table\ntitle: Orders\ndescription: Order fact table.\n" + withGenerated <- strictErrors (preamble <> "generated: { by: human:ahormati, at: 2026-06-20T22:53:05Z }\n---\nBody\n") + assertEqual [] withGenerated + withLegacyTimestamp <- strictErrors (preamble <> "timestamp: 2026-06-16T00:00:00Z\n---\nBody\n") + assertEqual [] withLegacyTimestamp + withNeither <- strictErrors (preamble <> "---\nBody\n") + assertEqual [MissingGeneratedField] withNeither + -- `generated` present but without the actor section 5.2 requires within it. + withoutActor <- strictErrors (preamble <> "generated: { at: 2026-06-20T22:53:05Z }\n---\nBody\n") + assertEqual [GeneratedMustHaveActor] withoutActor + -- Section 11 forbids rejecting a bundle for a missing optional field, so + -- neither diagnostic may fire under PermissiveConformance. + permissive <- validateDocument PermissiveConformance <$> firstShow (parseDocument (preamble <> "---\nBody\n")) + assertEqual [] permissive + +testRejectInvalidTags :: Either Text () +testRejectInvalidTags = do + document <- firstShow (parseDocument "---\ntype: BigQuery Table\ntags: orders\n---\nBody\n") + assertEqual [FieldMustBeListOfText "tags"] (validateDocument PermissiveConformance document) + +testRoundTrip :: Either Text () +testRoundTrip = do + document <- firstShow (parseDocument sampleDocument) + assertEqual [] (validateDocument PermissiveConformance document) + assertEqual [] (validateDocument StrictAuthoring document) + reparsed <- firstShow (parseDocument (serializeDocument document)) + assertEqual (document ^. #frontmatter) (reparsed ^. #frontmatter) + assertEqual (body document) (body reparsed) + +testRejectInvalidConceptId :: Either Text () +testRejectInvalidConceptId = + assertEqual (Left (InvalidConceptIdSegment "-users")) (parseConceptId "tables/-users") + +testConceptIdToFilePath :: Either Text () +testConceptIdToFilePath = do + conceptId <- firstShow (parseConceptId "tables/users") + assertEqual "tables/users.md" (conceptIdToFilePath conceptId) + +testWalkBundleMissingRoot :: IO (Either Text ()) +testWalkBundleMissingRoot = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-core-missing-parent" + let missingRoot = root "missing" + result <- walkBundle missingRoot + removeDirectoryRecursive root + pure + ( case result of + Left (BundleIoError path message) + | path == missingRoot && "does not exist" `Text.isInfixOf` message -> Right () + other -> Left ("expected missing-root BundleIoError, got " <> Text.pack (show other)) + ) + +testWalkBundleSkipsReserved :: IO (Either Text ()) +testWalkBundleSkipsReserved = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure (assertEqual ["datasets/sales", "tables/customers", "tables/orders"] (renderConceptId . conceptIdOf <$> concepts)) + ) + +-- | The gap this milestone closes: @references\/attesters\/revenue.py@ is +-- specification §6.3's own example of what an @attester.resource@ points at, and +-- before 'walkBundleInventory' existed nothing in okf could tell whether it was +-- there. It must be visible to the inventory without becoming a concept, since +-- only a @.md@ file carries frontmatter to validate. +testWalkBundleInventorySeesNonMarkdown :: IO (Either Text ()) +testWalkBundleInventorySeesNonMarkdown = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-core-inventory" + createFixtureBundle root + createDirectoryIfMissing True (root "references" "attesters") + Text.IO.writeFile (root "references" "attesters" "revenue.py") "print('receipt')\n" + concepts <- readBundle root + walked <- walkBundleInventory root + removeDirectoryRecursive root + pure + ( do + inventory <- firstShow walked + assertBool + "the .py file is in the inventory" + (bundleInventoryMember "references/attesters/revenue.py" inventory) + assertBool + "the .py file is not a concept" + (notElem "references/attesters/revenue" (renderConceptId . conceptIdOf <$> concepts)) + assertBool + "a concept's own file is in the inventory" + (bundleInventoryMember "tables/orders.md" inventory) + -- A reserved file is not a concept but is still a file, so a path naming + -- one names something that exists. + assertBool "a reserved file is in the inventory" (bundleInventoryMember "index.md" inventory) + assertBool + "a file that is not there is not in the inventory" + (not (bundleInventoryMember "references/attesters/gone.py" inventory)) + -- An in-memory bundle knows its own concepts and honestly cannot know + -- anything else. + let inMemory = bundleInventoryOfConcepts concepts + assertBool + "the in-memory inventory holds concept paths" + (bundleInventoryMember "tables/orders.md" inMemory) + assertBool + "the in-memory inventory cannot know a non-Markdown file" + (not (bundleInventoryMember "references/attesters/revenue.py" inMemory)) + ) + +testWalkBundleDiscoversNestedConceptIds :: IO (Either Text ()) +testWalkBundleDiscoversNestedConceptIds = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure + ( do + expected <- firstShow (parseConceptId "tables/orders") + assertBool "nested concept exists" (isJust (findConcept expected concepts)) + ) + ) + +-- | Build a throwaway directory tree, run an action on it, and clean up. +withDiscoveryTree :: String -> [(FilePath, Text)] -> (FilePath -> IO a) -> IO a +withDiscoveryTree label files action = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory label + for_ files $ \(relativePath, content) -> do + createDirectoryIfMissing True (root takeDirectory relativePath) + Text.IO.writeFile (root relativePath) content + result <- action root + removeDirectoryRecursive root + pure result + +typedConcept :: Text -> Text +typedConcept titleText = + Text.unlines ["---", "type: Table", "title: " <> titleText, "---", "", "# " <> titleText] + +plainMarkdown :: Text +plainMarkdown = "# Just prose\n\nNo frontmatter here.\n" + +testDiscoverIndexMd :: IO (Either Text ()) +testDiscoverIndexMd = + withDiscoveryTree "okf-discovery-index" [("kb/index.md", "# Index\n")] $ \root -> do + found <- discoverBundleRoots defaultDiscoveryOptions root + pure (assertEqual [normalise (root "kb")] found) + +testDiscoverTypedConcept :: IO (Either Text ()) +testDiscoverTypedConcept = + withDiscoveryTree "okf-discovery-typed" [("kb/tables/orders.md", typedConcept "Orders")] $ \root -> do + found <- discoverBundleRoots defaultDiscoveryOptions root + pure (assertEqual [normalise (root "kb" "tables")] found) + +testDiscoverIgnoresPlainMarkdown :: IO (Either Text ()) +testDiscoverIgnoresPlainMarkdown = + withDiscoveryTree + "okf-discovery-plain" + [("notes/README.md", plainMarkdown), ("notes/CHANGELOG.md", plainMarkdown)] + $ \root -> do + found <- discoverBundleRoots defaultDiscoveryOptions root + pure (assertEqual [] found) + +testDiscoverPrunesNestedBundles :: IO (Either Text ()) +testDiscoverPrunesNestedBundles = + withDiscoveryTree + "okf-discovery-prune" + [ ("kb/index.md", "# Index\n"), + ("kb/tables/index.md", "# Tables\n"), + ("kb/tables/orders.md", typedConcept "Orders") + ] + $ \root -> do + found <- discoverBundleRoots defaultDiscoveryOptions root + pure (assertEqual [normalise (root "kb")] found) + +testDiscoverSkipsNoise :: IO (Either Text ()) +testDiscoverSkipsNoise = + withDiscoveryTree + "okf-discovery-noise" + [ (".hidden/index.md", "# Hidden\n"), + ("dist-newstyle/index.md", "# Build output\n"), + ("kb/index.md", "# Index\n") + ] + $ \root -> do + found <- discoverBundleRoots defaultDiscoveryOptions root + pure (assertEqual [normalise (root "kb")] found) + +testDiscoverHonoursMaxDepth :: IO (Either Text ()) +testDiscoverHonoursMaxDepth = + withDiscoveryTree "okf-discovery-depth" [("a/b/c/index.md", "# Deep\n")] $ \root -> do + shallow <- discoverBundleRoots defaultDiscoveryOptions {maxDepth = 2} root + deep <- discoverBundleRoots defaultDiscoveryOptions {maxDepth = 3} root + pure (assertEqual [] shallow >> assertEqual [normalise (root "a" "b" "c")] deep) + +testDiscoverFixtureBundle :: IO (Either Text ()) +testDiscoverFixtureBundle = do + bundle <- fixturePath "valid-bundle" + found <- discoverBundleRoots defaultDiscoveryOptions bundle + pure (assertEqual [normalise bundle] found) + +testLogRoundTrip :: Either Text () +testLogRoundTrip = do + let canonicalLog = + Text.unlines + [ "# Directory Update Log", + "", + "## 2026-06-23", + "* **Update**: Refreshed [orders](tables/orders.md).", + "* **Creation**: Added customers.", + "", + "## 2026-06-01", + "* Deprecated a stale note." + ] + parsed = parseLog canonicalLog + reparsed = parseLog (serializeLog parsed) + assertEqual + ( Log + { logTitle = "Directory Update Log", + logDays = + [ LogDay + { logDate = "2026-06-23", + logEntries = + [ LogEntry (Just "Update") "Refreshed [orders](tables/orders.md).", + LogEntry (Just "Creation") "Added customers." + ] + }, + LogDay + { logDate = "2026-06-01", + logEntries = [LogEntry Nothing "Deprecated a stale note."] + } + ] + } + ) + parsed + assertEqual parsed reparsed + +testValidateLogNonIsoDate :: Either Text () +testValidateLogNonIsoDate = + assertBool + "expected LogDateNotIso" + (LogDateNotIso "not-a-date" `List.elem` validateLog (parseLog "# Log\n\n## not-a-date\n* **Update**: oops\n")) + +testValidateLogEmptyDay :: Either Text () +testValidateLogEmptyDay = + assertBool + "expected LogEmptyDay" + (LogEmptyDay "2026-06-23" `List.elem` validateLog (parseLog "# Log\n\n## 2026-06-23\n")) + +testValidateLogOutOfOrder :: Either Text () +testValidateLogOutOfOrder = + assertBool + "expected LogDaysOutOfOrder" + ( LogDaysOutOfOrder "2026-01-01" "2026-06-23" + `List.elem` validateLog (parseLog "# Log\n\n## 2026-01-01\n* Old.\n\n## 2026-06-23\n* New.\n") + ) + +testWalkLogsDiscoversNested :: IO (Either Text ()) +testWalkLogsDiscoversNested = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-core-logs" + createDirectoryIfMissing True (root "tables") + Text.IO.writeFile (root "log.md") "# Root Log\n\n## 2026-06-23\n* Root entry.\n" + Text.IO.writeFile (root "tables" "log.md") "# Tables Log\n\n## 2026-06-22\n* Tables entry.\n" + result <- walkLogs root + removeDirectoryRecursive root + pure + ( case result of + Right logs -> assertEqual ["log.md", "tables/log.md"] (logSourcePath <$> logs) + Left bundleError -> Left ("expected logs, got " <> Text.pack (show bundleError)) + ) + +testLogStalenessFlagsNewerConcept :: Either Text () +testLogStalenessFlagsNewerConcept = do + staleId <- parseTestConceptId "stale" + staleConcept <- testConceptWithTimestamp "stale" "2026-06-23T00:00:00Z" + currentConcept <- testConceptWithTimestamp "current" "2026-01-01T00:00:00Z" + let logs = [LogFile "log.md" (parseLog "# Log\n\n## 2026-06-01\n* **Update**: logged.\n")] + assertEqual + [ LogStaleness + { staleConcept = staleId, + staleConceptDate = "2026-06-23", + staleLogPath = Just "log.md", + staleLogDate = Just "2026-06-01" + } + ] + (logStaleness [staleConcept, currentConcept] logs) + +-- | Staleness reads the v0.2 `generated.at` (specification section 5.2), and +-- prefers it over the legacy `timestamp` it supersedes when both are present. +testLogStalenessReadsGeneratedAt :: Either Text () +testLogStalenessReadsGeneratedAt = do + generatedOnlyId <- parseTestConceptId "generated-only" + bothId <- parseTestConceptId "both" + generatedOnly <- + testConceptWithFrontmatter + "generated-only" + "type: Test\ngenerated: { by: human:ahormati, at: 2026-06-23T00:00:00Z }\n" + -- `generated.at` wins over `timestamp`: the stale date must be the June 24 + -- from `generated`, not the January 1 from the legacy key. + bothKeys <- + testConceptWithFrontmatter + "both" + "type: Test\ngenerated: { by: human:ahormati, at: 2026-06-24T00:00:00Z }\ntimestamp: 2026-01-01T00:00:00Z\n" + let logs = [LogFile "log.md" (parseLog "# Log\n\n## 2026-06-01\n* **Update**: logged.\n")] + assertEqual + [ LogStaleness bothId "2026-06-24" (Just "log.md") (Just "2026-06-01"), + LogStaleness generatedOnlyId "2026-06-23" (Just "log.md") (Just "2026-06-01") + ] + (logStaleness [bothKeys, generatedOnly] logs) + +testLogStalenessPrefersDeepestLog :: Either Text () +testLogStalenessPrefersDeepestLog = do + usersId <- parseTestConceptId "tables/users" + usersConcept <- testConceptWithTimestamp "tables/users" "2026-06-21T00:00:00Z" + let logs = + [ LogFile "log.md" (parseLog "# Root Log\n\n## 2026-06-01\n* **Update**: root.\n"), + LogFile "tables/log.md" (parseLog "# Tables Log\n\n## 2026-06-20\n* **Update**: tables.\n") + ] + assertEqual + [ LogStaleness + { staleConcept = usersId, + staleConceptDate = "2026-06-21", + staleLogPath = Just "tables/log.md", + staleLogDate = Just "2026-06-20" + } + ] + (logStaleness [usersConcept] logs) + +testAppendLogEntry :: Either Text () +testAppendLogEntry = + assertEqual + ( Log + { logTitle = "Log", + logDays = + [ LogDay "2026-06-23" [LogEntry (Just "Update") "new"], + LogDay "2026-06-01" [LogEntry (Just "Update") "prepended", LogEntry (Just "Creation") "old"] + ] + } + ) + ( appendLogEntry + "2026-06-01" + (LogEntry (Just "Update") "prepended") + ( appendLogEntry + "2026-06-23" + (LogEntry (Just "Update") "new") + (Log "Log" [LogDay "2026-06-01" [LogEntry (Just "Creation") "old"]]) + ) + ) + +testGenerateIndexGroupsByType :: IO (Either Text ()) +testGenerateIndexGroupsByType = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure + ( do + orders <- requireConcept "tables/orders" concepts + customers <- requireConcept "tables/customers" concepts + let rendered = renderIndex [] [] [orders, customers] + assertBool "has type heading" ("# BigQuery Table" `Text.isInfixOf` rendered) + assertBool "has orders bullet" ("[Orders](orders.md) - Order records." `Text.isInfixOf` rendered) + assertBool "has customers bullet" ("[Customers](customers.md) - Customer records." `Text.isInfixOf` rendered) + -- §8's progressive disclosure reaches a file with no frontmatter: + -- a directory holding only an attester used to render one newline. + let withFiles = renderIndex [] ["revenue.py"] [] + -- The trailing blank line is 'renderIndex''s own, appended after + -- every section; a concepts-only index ends the same way. + assertEqual "# Files\n\n- [revenue.py](revenue.py)\n\n" withFiles + ) + ) + +testExtractLinksResolveBundleLinks :: IO (Either Text ()) +testExtractLinksResolveBundleLinks = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure + ( do + orders <- requireConcept "tables/orders" concepts + customers <- firstShow (parseConceptId "tables/customers") + sales <- firstShow (parseConceptId "datasets/sales") + let links = extractConceptLinks orders + assertBool "absolute or ./ customers link" (customers `List.elem` links) + assertBool "../ sales link" (sales `List.elem` links) + ) + ) + +testExtractLinksIgnoresExternalUrls :: IO (Either Text ()) +testExtractLinksIgnoresExternalUrls = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure + ( do + orders <- requireConcept "tables/orders" concepts + assertEqual 4 (length (extractConceptLinks orders)) + ) + ) + +testBuildGraphIncludesKnownEdges :: IO (Either Text ()) +testBuildGraphIncludesKnownEdges = + withFixtureBundle + ( \root -> do + concepts <- readBundle root + pure + ( do + orders <- firstShow (parseConceptId "tables/orders") + customers <- firstShow (parseConceptId "tables/customers") + missing <- firstShow (parseConceptId "missing") + let graph = buildGraph concepts + assertEqual 3 (length (nodes graph)) + assertBool "known edge exists" (Edge {source = orders, target = customers} `List.elem` edges graph) + assertBool "broken edge excluded" (Edge {source = orders, target = missing} `notElem` edges graph) + ) + ) + +testWriteBundleIndexesDeterministic :: IO (Either Text ()) +testWriteBundleIndexesDeterministic = + withFixtureBundle + ( \root -> do + firstResult <- writeBundleIndexes root + firstIndex <- Text.IO.readFile (root "tables" "index.md") + secondResult <- writeBundleIndexes root + secondIndex <- Text.IO.readFile (root "tables" "index.md") + pure + ( do + firstShow firstResult + firstShow secondResult + assertEqual firstIndex secondIndex + assertBool "tables index has BigQuery Table section" ("# BigQuery Table" `Text.isInfixOf` secondIndex) + ) + ) + +-- | Specification §12 permits a bundle-root @index.md@ to declare the version +-- it targets. Every shape of that declaration is readable and none is fatal. +testReadBundleVersion :: IO (Either Text ()) +testReadBundleVersion = do + declared <- versionOf [("index.md", "---\nokf_version: \"0.2\"\n---\n\n# Root\n")] + noKey <- versionOf [("index.md", "---\ntitle: Root\n---\n\n# Root\n")] + noFrontmatter <- versionOf [("index.md", "# Root\n")] + noIndex <- versionOf [("kb.md", "# Not an index\n")] + unparseable <- versionOf [("index.md", "---\nokf_version: \"zero point two\"\n---\n\n# Root\n")] + malformed <- versionOf [("index.md", "---\nokf_version: \"0.2\"\n\n# Root\n")] + pure $ do + assertEqual (Right (VersionDeclared (OkfVersion 0 2))) declared + assertEqual (Right VersionUndeclared) noKey + assertEqual (Right VersionUndeclared) noFrontmatter + assertEqual (Right VersionUndeclared) noIndex + assertEqual (Right (VersionUnparseable "zero point two")) unparseable + assertEqual (Right VersionUndeclared) malformed + +-- | A careless author writes @okf_version: 0.2@ without quotes, which YAML +-- reads as a float. A bundle should not be unreadable over missing quotes. +testReadBundleVersionUnquoted :: IO (Either Text ()) +testReadBundleVersionUnquoted = do + unquoted <- versionOf [("index.md", "---\nokf_version: 0.2\n---\n\n# Root\n")] + pure (assertEqual (Right (VersionDeclared (OkfVersion 0 2))) unquoted) + +versionOf :: [(FilePath, Text)] -> IO (Either BundleError VersionDeclaration) +versionOf files = + withDiscoveryTree "okf-version" files readBundleVersion + +-- | Index generation rewrites the bundle root's @index.md@, so without reading +-- the existing declaration first a single write destroys it. Fails on the code +-- that preceded this test. +testWriteBundleIndexesPreservesVersion :: IO (Either Text ()) +testWriteBundleIndexesPreservesVersion = + withDiscoveryTree + "okf-version-preserve" + [ ("index.md", "---\nokf_version: \"0.2\"\n---\n\n# Root\n"), + ("tables/orders.md", typedConcept "Orders") + ] + ( \root -> do + written <- writeBundleIndexes root + rootIndex <- Text.IO.readFile (root "index.md") + tablesIndex <- Text.IO.readFile (root "tables" "index.md") + declaration <- readBundleVersion root + pure + ( do + firstShow written + assertEqual (Right (VersionDeclared (OkfVersion 0 2))) declaration + assertBool "root index keeps the declaration" ("okf_version: \"0.2\"" `Text.isInfixOf` rootIndex) + assertBool "root index still lists subdirectories" ("[tables/](tables/index.md)" `Text.isInfixOf` rootIndex) + assertBool "only the root index carries frontmatter" (not ("---" `Text.isInfixOf` tablesIndex)) + ) + ) + +-- | An explicit declaration is written where there was none; a bundle that +-- declares nothing keeps a frontmatter-free root index. +testWriteBundleIndexesDeclaresVersion :: IO (Either Text ()) +testWriteBundleIndexesDeclaresVersion = + withDiscoveryTree + "okf-version-declare" + [("tables/orders.md", typedConcept "Orders")] + ( \root -> do + untouched <- writeBundleIndexes root + withoutDeclaration <- Text.IO.readFile (root "index.md") + declared <- writeBundleIndexesWith (Just (OkfVersion 0 2)) root + withDeclaration <- Text.IO.readFile (root "index.md") + pure + ( do + firstShow untouched + firstShow declared + assertBool "undeclared bundle gets no frontmatter" (not ("---" `Text.isInfixOf` withoutDeclaration)) + assertEqual + ("---\nokf_version: \"0.2\"\n---\n\n" <> withoutDeclaration) + withDeclaration + ) + ) + +testFixtureValidBundle :: IO (Either Text ()) +testFixtureValidBundle = do + root <- fixturePath "valid-bundle" + concepts <- readBundle root + inventory <- readBundleInventory root + declaration <- readBundleVersion root + pure + ( do + orders <- firstShow (parseConceptId "tables/orders") + customers <- firstShow (parseConceptId "tables/customers") + sales <- firstShow (parseConceptId "datasets/sales") + assertEqual 4 (length concepts) + assertEqual [] (foldMap (validateDocument PermissiveConformance . conceptDocument) concepts) + -- The primary fixture is a v0.2 bundle: it declares the version and + -- every concept dates itself with `generated` rather than the + -- superseded `timestamp`. + assertEqual (Right (VersionDeclared (OkfVersion 0 2))) declaration + assertEqual [] (validateBundle StrictAuthoring (VersionDeclared (OkfVersion 0 2)) inventory concepts) + assertBool + "every concept carries generated" + (all (isJust . conceptGenerated) concepts) + let graph = buildGraph concepts + assertBool "orders to customers" (Edge {source = orders, target = customers} `List.elem` edges graph) + assertBool "orders to sales" (Edge {source = orders, target = sales} `List.elem` edges graph) + ) + +-- | The v0.1 fallback of @docs\/adr\/7-okf-v0-1-legacy-fallback-policy.md@ needs +-- a bundle in the old shape or it will rot. This fixture is that bundle, and is +-- deliberately never migrated: it dates its concept with the superseded +-- @timestamp@ and declares no @okf_version@, so strict validation must report +-- nothing at all. +testFixtureV01LegacyBundle :: IO (Either Text ()) +testFixtureV01LegacyBundle = do + root <- fixturePath "v01-legacy-bundle" + concepts <- readBundle root + inventory <- readBundleInventory root + declaration <- readBundleVersion root + pure + ( do + assertEqual 1 (length concepts) + assertEqual (Right VersionUndeclared) declaration + assertEqual [] (validateBundle StrictAuthoring VersionUndeclared inventory concepts) + assertBool + "the concept carries no generated family" + (all (isNothing . conceptGenerated) concepts) + -- The date is still read, which is the whole point of the fallback. + assertEqual ["2026-06-16"] (staleConceptDate <$> logStaleness concepts []) + ) + +testFixtureGraphJsonShape :: IO (Either Text ()) +testFixtureGraphJsonShape = do + root <- fixturePath "valid-bundle" + concepts <- readBundle root + orders <- requireConceptIO "tables/orders" concepts + pure + ( case filter (\Node {id = nodeId} -> nodeId == conceptIdOf orders) (nodes (buildGraph concepts)) of + [ordersNode] -> + assertEqual + ( object + [ "id" .= ("tables/orders" :: Text), + "label" .= ("Orders" :: Text), + "type" .= ("BigQuery Table" :: Text), + "description" .= Just ("Order fact table." :: Text), + "resource" .= Just ("bigquery://analytics.tables.orders" :: Text), + "tags" .= ["orders" :: Text, "sales"] + ] + ) + (toJSON ordersNode) + other -> Left ("expected one orders node, got " <> Text.pack (show (length other))) + ) + +testFixtureUnterminatedFrontmatter :: IO (Either Text ()) +testFixtureUnterminatedFrontmatter = do + root <- fixturePath "invalid-unterminated-frontmatter" + result <- walkBundle root + pure + ( case result of + Left (InvalidConceptDocument "broken.md" UnterminatedFrontmatter) -> Right () + other -> Left ("expected unterminated frontmatter error, got " <> Text.pack (show other)) + ) + +testFixtureMissingType :: IO (Either Text ()) +testFixtureMissingType = do + root <- fixturePath "invalid-missing-type" + concepts <- readBundle root + pure + ( do + assertEqual 1 (length concepts) + case foldMap (validateDocument PermissiveConformance . conceptDocument) concepts of + [MissingRequiredField "type"] -> Right () + other -> Left ("expected missing type error, got " <> Text.pack (show other)) + ) + +testFrontmatterBuilderRoundTrip :: Either Text () +testFrontmatterBuilderRoundTrip = do + let generatedValue = Generated (parseActor "reference_agent/gemini-2.5-pro") (Just "2026-06-20T22:53:05Z") + frontmatterValue = + setField "version" (String "0.2.0") + . setTags ["orders", "sales"] + . setResource "bigquery://analytics.tables.orders" + . setGenerated generatedValue + $ okfCommon + OkfCommon + { commonType = "BigQuery Table", + commonTitle = Just "Orders", + commonDescription = Just "Order fact table.", + commonTimestamp = Just "2026-06-16T00:00:00Z" + } + original = OKFDocument frontmatterValue "# Orders\n\nBody text.\n" + reparsed <- firstShow (parseDocument (serializeDocument original)) + assertEqual (original ^. #frontmatter) (reparsed ^. #frontmatter) + assertEqual (body original) (body reparsed) + -- The v0.2 family survives serialize-then-parse as a typed value, not merely + -- as equal frontmatter, and a `generated` without `at` round-trips too. + assertEqual (Just generatedValue) (readGenerated (reparsed ^. #frontmatter)) + let withoutAt = setGenerated (Generated (HumanActor "ahormati") Nothing) emptyFrontmatter + reparsedWithoutAt <- firstShow (parseDocument (serializeDocument (OKFDocument withoutAt "# Orders\n"))) + assertEqual + (Just (Generated (HumanActor "ahormati") Nothing)) + (readGenerated (reparsedWithoutAt ^. #frontmatter)) + +testSerializeDeterministicKeyOrder :: Either Text () +testSerializeDeterministicKeyOrder = do + let frontmatterValue = + setField "zeta" (String "z") + . setField "alpha" (String "a") + . setTags ["t"] + . setResource "res://x" + . setType "Recipe" + . setTimestamp "2026-06-16T00:00:00Z" + . setDescription "Desc" + . setTitle "Demo" + $ emptyFrontmatter + rendered = serializeDocument (OKFDocument frontmatterValue "# Demo\n") + expectedOrder = + ["type:", "title:", "description:", "resource:", "tags:", "timestamp:", "alpha:", "zeta:"] + keyIndices <- traverse (\key -> maybe (Left ("missing key " <> key)) Right (substringIndex key rendered)) expectedOrder + assertBool ("keys not in deterministic order: " <> Text.pack (show keyIndices)) (strictlyIncreasing keyIndices) + +-- | The v0.2 @generated@ family sorts before the v0.1 @timestamp@ it supersedes +-- (specification section 13.1), so a document carrying both reads with the +-- current field first. +testSerializeGeneratedBeforeTimestamp :: Either Text () +testSerializeGeneratedBeforeTimestamp = do + let frontmatterValue = + setTimestamp "2026-06-16T00:00:00Z" + . setField "generated" (object ["by" .= ("human:ahormati" :: Text), "at" .= ("2026-06-20T22:53:05Z" :: Text)]) + . setType "Recipe" + $ emptyFrontmatter + rendered = serializeDocument (OKFDocument frontmatterValue "# Demo\n") + expectedOrder = ["type:", "generated:", "timestamp:"] + keyIndices <- traverse (\key -> maybe (Left ("missing key " <> key)) Right (substringIndex key rendered)) expectedOrder + assertBool ("keys not in deterministic order: " <> Text.pack (show keyIndices)) (strictlyIncreasing keyIndices) + +-- | Footnotes are enabled at every parse site, and the observable proof is a +-- link that no longer appears. +-- +-- With footnotes disabled a single-token footnote definition such as +-- @[^src]: tables\/orders.md@ is read as a CommonMark /link reference +-- definition/, which turns its citation @[^src]@ into a link whose destination +-- is that token. That phantom link reached 'extractConceptLinks' and was then +-- reported as a dangling reference. Enabling footnotes removes it while leaving +-- an ordinary link in the same body alone. +testFootnotesEnabled :: Either Text () +testFootnotesEnabled = do + ordersId <- parseTestConceptId "tables/orders" + usersId <- parseTestConceptId "tables/users" + concept <- + testConcept + "source" + ( "See the note.[^src] Also see " + <> renderConceptLink usersId "users" + <> ".\n\n[^src]: tables/orders.md\n" + ) + assertEqual [usersId] (extractConceptLinks concept) + assertBool + "footnote definition must not become a link reference definition" + (ordersId `notElem` extractConceptLinks concept) + +-- | Enabling footnotes changes the parse tree every body walker sees, so pin +-- the two walkers that do not care about footnotes at all: log parsing and link +-- extraction. Bracket-heavy prose in a log bullet must still yield one entry +-- with its text intact, and a body whose links sit inside a /cited/ footnote +-- definition must still contribute those links to the graph. +testFootnotesDoNotRegressLogsOrLinks :: Either Text () +testFootnotesDoNotRegressLogsOrLinks = do + let parsed = parseLog "# Log\n\n## 2026-06-23\n* **Update**: renamed [orders] to [^orders].\n" + -- The backslashes are 'Okf.Log.renderInlineNodes' round-tripping inline nodes + -- through @nodeToCommonmark@, which escapes brackets so the text re-parses to + -- itself. That predates footnotes and is unchanged by them: an uncited + -- @[^orders]@ is plain text under either parse configuration. + assertEqual + [LogDay "2026-06-23" [LogEntry (Just "Update") "renamed \\[orders\\] to \\[^orders\\]."]] + (logDays parsed) + usersId <- parseTestConceptId "tables/users" + concept <- + testConcept + "source" + ( "Attributed claim.[^cited]\n\n[^cited]: See " + <> renderConceptLink usersId "users" + <> " for detail.\n" + ) + assertEqual [usersId] (extractConceptLinks concept) + +-- | Labels come from a real parse, not a naive text scan: footnote syntax +-- inside an inline code span, an indented code block, or a fenced code block +-- yields nothing. +testExtractFootnoteLabelsIgnoresCode :: Either Text () +testExtractFootnoteLabelsIgnoresCode = do + let body = + Text.unlines + [ "Sharded daily.[^ga4-schema] Not a footnote: `[^inline-code]`.", + "", + " [^indented-block]: not a footnote either", + "", + "```sql", + "SELECT 1 -- [^fenced-block]: not a footnote", + "```", + "", + "Undefined citation.[^never-defined]", + "", + "[^ga4-schema]: GA4 BigQuery Export schema" + ] + labels = extractFootnoteLabels body + assertEqual ["ga4-schema", "never-defined"] (footnoteReferences labels) + assertEqual ["ga4-schema"] (footnoteDefinitions labels) + assertEqual ["ga4-schema", "never-defined"] (footnoteLabelsUsed labels) + +-- | The two labels cmark-gfm erases are exactly the two an author most needs +-- reported, so extraction must keep both: a citation with no definition (which +-- the parser reverts to plain text) and a definition nothing cites (which the +-- parser deletes outright). The ordinal guard is the same test's second job — +-- cmark-gfm renumbers a matched reference to @"1"@, so a label that parses as a +-- bare integer would mean extraction had drifted back onto the parse tree. +testExtractFootnoteLabelsKeepsErasedLabels :: Either Text () +testExtractFootnoteLabelsKeepsErasedLabels = do + let body = + Text.unlines + [ "Matched.[^matched] Undefined.[^undefined]", + "", + "[^matched]: a definition that is cited", + "", + "[^uncited]: a definition that nothing cites" + ] + labels = extractFootnoteLabels body + assertEqual ["matched", "undefined"] (footnoteReferences labels) + assertEqual ["matched", "uncited"] (footnoteDefinitions labels) + assertBool + "no extracted label may be a bare ordinal" + (not (any looksLikeInteger (footnoteLabelsUsed labels))) + where + looksLikeInteger label = + not (Text.null label) && Text.all (`Text.elem` "0123456789") label + +-- | Specification §10.3's prose says "fenced" and §10.2's own worked example +-- writes an indented block, so both count; and the section is bounded at the +-- next heading of the same or a shallower level, so a fenced block under a later +-- @# Notes@ heading is not a second computation while one under a nested +-- @## Subsection@ still belongs to the section. +testComputationBlocks :: Either Text () +testComputationBlocks = do + assertEqual + ["SELECT 1\n"] + (computationBlocks (Text.unlines ["# Computation", "", " SELECT 1"])) + assertEqual + ["SELECT 1\n"] + (computationBlocks (Text.unlines ["# Computation", "", "```sql", "SELECT 1", "```"])) + assertEqual + ["SELECT 1\n"] + ( computationBlocks + ( Text.unlines + [ "# Computation", + "", + " SELECT 1", + "", + "# Notes", + "", + "```sql", + "SELECT 2", + "```" + ] + ) + ) + assertEqual + ["SELECT 1\n", "SELECT 2\n"] + ( computationBlocks + ( Text.unlines + [ "# Computation", + "", + " SELECT 1", + "", + "## Explanation", + "", + "```sql", + "SELECT 2", + "```" + ] + ) + ) + assertEqual + ["SELECT 1\n", "SELECT 2\n"] + ( computationBlocks + ( Text.unlines + ["# Computation", "", "```sql", "SELECT 1", "```", "", "```sql", "SELECT 2", "```"] + ) + ) + assertEqual + [] + (computationBlocks (Text.unlines ["# Notes", "", "```sql", "SELECT 1", "```"])) + assertEqual + ["SELECT 1\n"] + (computationBlocks (Text.unlines ["## computation ", "", " SELECT 1"])) + +-- | The one erasure that reaches 'computationBlocks', pinned so that meeting it +-- later is recognized rather than investigated. Per +-- @docs/adr/9-one-markdown-parse-configuration-and-source-scanned-authoring-checks.md@, +-- okf parses every body with footnotes enabled and cmark-gfm deletes a footnote +-- definition nothing cites, content and all — so a computation hidden inside one +-- is invisible here. The document is malformed in a second, unrelated way, so +-- this is an accepted cost rather than a bug to work around. +testComputationBlocksFootnoteHazard :: Either Text () +testComputationBlocksFootnoteHazard = + assertEqual + [] + ( computationBlocks + ( Text.unlines + ["# Computation", "", "[^unused]: a definition nothing cites", "", " SELECT 1"] + ) + ) + +testConceptLinkRoundTrip :: Either Text () +testConceptLinkRoundTrip = do + sourceId <- parseTestConceptId "recipes/haskell-library-repo" + let targetStrings = ["orders", "modules/nix-haskell-flake", "refs/source-system.v1"] + mapM_ + ( \rawTarget -> do + targetId <- parseTestConceptId rawTarget + let extracted = extractFromBodyLinkingTo sourceId targetId + assertEqual [targetId] extracted + ) + targetStrings + +parseTestConceptId :: Text -> Either Text ConceptId +parseTestConceptId rawId = + first (\err -> "bad concept id " <> rawId <> ": " <> Text.pack (show err)) (parseConceptId rawId) + +extractFromBodyLinkingTo :: ConceptId -> ConceptId -> [ConceptId] +extractFromBodyLinkingTo sourceId targetId = + extractConceptLinks + (conceptFromDocument sourceId (OKFDocument (setType "Test" emptyFrontmatter) ("See " <> renderConceptLink targetId "link" <> ".\n"))) + +testRejectOverEscapingRelativeLink :: Either Text () +testRejectOverEscapingRelativeLink = do + sourceId <- parseTestConceptId "a/b/source" + targetId <- parseTestConceptId "tables/orders" + let concept = + conceptFromDocument + sourceId + (OKFDocument (setType "Test" emptyFrontmatter) "[Escapes](../../../tables/orders.md)\n") + assertEqual [] (extractConceptLinks concept) + assertEqual [] (validateInMemoryBundle PermissiveConformance VersionUndeclared [concept, targetConcept targetId]) + where + targetConcept targetId = + conceptFromDocument + targetId + (OKFDocument (setType "Test" emptyFrontmatter) "# Orders\n") + +-- | Specification §6.2: each path-valued field accepts an absolute URL, a +-- bundle-relative path beginning with @/@, or an ordinary relative path. +-- Classification is total, so a value that is none of the three lands on a named +-- alternative rather than being dropped. +testClassifyPathReference :: Either Text () +testClassifyPathReference = do + deep <- parseTestConceptId "metrics/finance/revenue" + shallow <- parseTestConceptId "revenue" + -- An absolute URL yields its case-folded scheme, whatever the scheme is: §6.2 + -- names no allowed set, so deciding that is the profile's job. + assertEqual (ExternalUrl "https") (classifyPathReference deep "https://wiki.acme/revenue") + assertEqual (ExternalUrl "mori") (classifyPathReference deep "mori://shinzui/okf") + assertEqual (ExternalUrl "https") (classifyPathReference deep "HTTPS://wiki.acme/revenue") + -- A leading slash resolves from the bundle root regardless of where the + -- concept carrying the value lives. + assertEqual (BundlePath "references/policy.md") (classifyPathReference deep "/references/policy.md") + assertEqual (BundlePath "references/policy.md") (classifyPathReference shallow "/references/policy.md") + -- A relative path resolves against the source concept's own directory. + assertEqual + (BundlePath "metrics/finance/policy.md") + (classifyPathReference deep "policy.md") + assertEqual + (BundlePath "metrics/computations/revenue.md") + (classifyPathReference deep "../computations/revenue.md") + assertEqual (BundlePath "policy.md") (classifyPathReference shallow "./policy.md") + -- A fragment or query suffix names the same target as the bare path. + assertEqual (BundlePath "references/policy.md") (classifyPathReference deep "/references/policy.md#recognition") + assertEqual (BundlePath "references/policy.md") (classifyPathReference deep "/references/policy.md?v=2") + -- Non-Markdown targets classify identically; only the caller cares about the + -- extension. + assertEqual + (BundlePath "references/attesters/revenue.py") + (classifyPathReference deep "/references/attesters/revenue.py") + -- Climbing above the bundle root is its own outcome, distinct from malformed: + -- the author wrote a well-formed relative path that points outside. + assertEqual EscapesBundle (classifyPathReference shallow "../../etc/passwd") + assertEqual EscapesBundle (classifyPathReference deep "../../../../elsewhere.md") + -- Text that names nothing at all. + assertEqual MalformedPath (classifyPathReference deep "") + assertEqual MalformedPath (classifyPathReference deep " ") + assertEqual MalformedPath (classifyPathReference deep "#recognition") + -- 'collapseBundlePath' is exported for the same reason it is shared: one + -- spelling of "does this climb out of the bundle". + assertEqual (Just "references/policy.md") (collapseBundlePath "references/./policy.md") + assertEqual (Just "policy.md") (collapseBundlePath "references/../policy.md") + assertEqual Nothing (collapseBundlePath "../policy.md") + +-- | The seam 'Okf.Path' deliberately left open: classification says what shape a +-- value has, resolution says whether the thing it names is there. The predicate +-- stands in for a 'BundleInventory' so the two can be tested apart. +testResolvePathReference :: Either Text () +testResolvePathReference = do + deep <- parseTestConceptId "metrics/finance/revenue" + shallow <- parseTestConceptId "revenue" + let present = + [ "references/policy.md", + "references/attesters/revenue.py", + "metrics/finance/policy.md", + "sibling.md" + ] + exists = (`elem` present) + resolve = resolvePathReference exists + -- Every scheme counts, not only the three 'Okf.Graph.isExternalUrl' knows + -- about, and okf never fetches any of them. + assertEqual (ResolvedExternal "https") (resolve deep "https://wiki.acme/revenue") + assertEqual (ResolvedExternal "bigquery") (resolve deep "bigquery://analytics.tables.orders") + -- A leading slash resolves from the bundle root wherever the concept lives. + assertEqual (ResolvedInBundle "references/policy.md") (resolve deep "/references/policy.md") + assertEqual (ResolvedInBundle "references/policy.md") (resolve shallow "/references/policy.md") + -- A relative path resolves against the carrying concept's own directory. + assertEqual (ResolvedInBundle "metrics/finance/policy.md") (resolve deep "policy.md") + assertEqual (ResolvedInBundle "sibling.md") (resolve shallow "./sibling.md") + -- The case this whole plan exists for: a non-Markdown target resolves, which + -- is only possible because the inventory sees more than concepts. + assertEqual + (ResolvedInBundle "references/attesters/revenue.py") + (resolve deep "/references/attesters/revenue.py") + -- Nothing there under that name. + assertEqual (DanglingInBundle "references/deleted.md") (resolve deep "/references/deleted.md") + assertEqual (DanglingInBundle "metrics/computations/revenue.md") (resolve deep "../computations/revenue.md") + -- Distinct outcomes for a value that could never name anything in the bundle. + assertEqual UnresolvableEscape (resolve shallow "../../etc/passwd") + assertEqual UnresolvableMalformed (resolve deep "") + assertEqual UnresolvableMalformed (resolve deep " ") + +-- | The version-metadata lists name keys okf actually owns. Nothing else would +-- catch a typo in one of those string literals: a misspelled entry simply never +-- matches a rule, so the check it drives goes quietly missing. +testVersionedFieldsAreCoreFields :: Either Text () +testVersionedFieldsAreCoreFields = do + assertEqual [] (filter (`Set.notMember` coreFrontmatterFields) fieldsIntroducedInV02) + assertEqual [] (filter (`Set.notMember` coreFrontmatterFields) fieldsSupersededInV02) + -- The two lists are about different versions of the same key set and must not + -- overlap: a key cannot be both introduced and superseded by v0.2. + assertEqual [] (filter (`elem` fieldsSupersededInV02) fieldsIntroducedInV02) + +-- | Specification §12: a known major with a higher minor is read as the highest +-- version okf understands within that major, because a minor bump is defined as +-- backward-compatible additions. An unknown major is read with no +-- version-specific rules at all. +testVersionGate :: Either Text () +testVersionGate = do + assertEqual Nothing (gateEffective (versionGate VersionUndeclared)) + assertEqual Nothing (gateEffective (versionGate (VersionUnparseable "zero point two"))) + assertEqual (Just (OkfVersion 0 1)) (gateEffective (versionGate (VersionDeclared (OkfVersion 0 1)))) + assertEqual (Just (OkfVersion 0 2)) (gateEffective (versionGate (VersionDeclared (OkfVersion 0 2)))) + assertEqual (Just (OkfVersion 0 2)) (gateEffective (versionGate (VersionDeclared (OkfVersion 0 3)))) + assertEqual Nothing (gateEffective (versionGate (VersionDeclared (OkfVersion 1 0)))) + assertEqual (Just "1.0") (gateNotUnderstood (versionGate (VersionDeclared (OkfVersion 1 0)))) + assertEqual Nothing (gateNotUnderstood (versionGate (VersionDeclared (OkfVersion 0 3)))) + assertBool "0.2 satisfies at-least 0.2" (gateDeclaresAtLeast (OkfVersion 0 2) (versionGate (VersionDeclared (OkfVersion 0 2)))) + assertBool "0.1 does not satisfy at-least 0.2" (not (gateDeclaresAtLeast (OkfVersion 0 2) (versionGate (VersionDeclared (OkfVersion 0 1))))) + assertBool "undeclared satisfies nothing" (not (gateDeclaresAtLeast (OkfVersion 0 2) (versionGate VersionUndeclared))) + +-- | The asymmetry this plan exists for: the v0.1 fallback stays unconditional, +-- but a bundle that has declared v0.2 and still carries @timestamp@ is +-- reporting an authoring mistake. +testLegacyFieldInDeclaredV2 :: Either Text () +testLegacyFieldInDeclaredV2 = do + conceptId <- parseTestConceptId "tables/orders" + legacyOnly <- + testConceptWithFrontmatter + "tables/orders" + "type: Test\ntitle: Title\ndescription: Description\ntimestamp: \"2026-06-16T00:00:00Z\"\n" + migrated <- + testConceptWithFrontmatter + "tables/orders" + "type: Test\ntitle: Title\ndescription: Description\ngenerated:\n by: okf/0.4\n at: \"2026-06-16T00:00:00Z\"\n" + let declaredV2 = VersionDeclared (OkfVersion 0 2) + assertEqual [] (validateInMemoryBundle StrictAuthoring VersionUndeclared [legacyOnly]) + assertEqual [] (validateInMemoryBundle PermissiveConformance declaredV2 [legacyOnly]) + assertEqual + [DocumentInvalid conceptId (LegacyFieldInDeclaredV2 "timestamp")] + (validateInMemoryBundle StrictAuthoring declaredV2 [legacyOnly]) + assertEqual [] (validateInMemoryBundle StrictAuthoring declaredV2 [migrated]) + -- An unknown major applies no version-specific rule, so the same document is + -- read the way an undeclared bundle's would be. + assertEqual + [BundleVersionNotUnderstood "1.0"] + (validateInMemoryBundle StrictAuthoring (VersionDeclared (OkfVersion 1 0)) [legacyOnly]) + +-- | §12: "Consumers that do not understand the declared version SHOULD attempt +-- best-effort consumption rather than refusing the bundle." Neither an +-- unreadable value nor an unknown major stops the bundle being read, and +-- neither is reported outside strict authoring. +testVersionDeclarationLints :: Either Text () +testVersionDeclarationLints = do + -- A migrated concept, so the only diagnostics here are version ones. + concept <- + testConceptWithFrontmatter + "a" + "type: Test\ntitle: Title\ndescription: Description\ngenerated:\n by: okf/0.4\n at: \"2026-06-16T00:00:00Z\"\n" + assertEqual [] (validateInMemoryBundle PermissiveConformance (VersionUnparseable "0.x") [concept]) + assertEqual [] (validateInMemoryBundle PermissiveConformance (VersionDeclared (OkfVersion 1 0)) [concept]) + assertEqual + [BundleVersionUnparseable "0.x"] + (validateInMemoryBundle StrictAuthoring (VersionUnparseable "0.x") [concept]) + assertEqual + [BundleVersionNotUnderstood "1.0"] + (validateInMemoryBundle StrictAuthoring (VersionDeclared (OkfVersion 1 0)) [concept]) + -- A higher minor within a known major is a supported case, not a problem. + assertEqual [] (validateInMemoryBundle StrictAuthoring (VersionDeclared (OkfVersion 0 3)) [concept]) + +testValidateBundleDanglingReference :: Either Text () +testValidateBundleDanglingReference = do + aId <- parseTestConceptId "a" + bId <- parseTestConceptId "b" + conceptA <- testConcept "a" ("See " <> renderConceptLink bId "b" <> ".\n") + assertEqual [DanglingReference aId bId] (validateInMemoryBundle StrictAuthoring VersionUndeclared [conceptA]) + +testValidateBundleAcceptsResolved :: Either Text () +testValidateBundleAcceptsResolved = do + bId <- parseTestConceptId "b" + conceptA <- testConcept "a" ("See " <> renderConceptLink bId "b" <> ".\n") + conceptB <- testConcept "b" "Standalone.\n" + assertEqual [] (validateInMemoryBundle StrictAuthoring VersionUndeclared [conceptA, conceptB]) + +-- | The §6.2 path check, at the level where its placement decisions live: strict +-- only, dangling only, and never over @sources[].resource@. +testValidateBundleDanglingFrontmatterPath :: Either Text () +testValidateBundleDanglingFrontmatterPath = do + aId <- parseTestConceptId "a" + conceptB <- testConcept "b" "Standalone.\n" + let withResource value = + testConceptWithFrontmatter + "a" + ( "type: Test\ntitle: Title\ndescription: Description\n" + <> "generated:\n by: okf/0.4\n at: \"2026-06-16T00:00:00Z\"\n" + <> "resource: " + <> value + <> "\n" + ) + strict concepts = validateInMemoryBundle StrictAuthoring VersionUndeclared concepts + permissive concepts = validateInMemoryBundle PermissiveConformance VersionUndeclared concepts + danglingResource <- withResource "/references/deleted.md" + resolvedResource <- withResource "/b.md" + externalResource <- withResource "bigquery://analytics.tables.orders" + escapingResource <- withResource "../../elsewhere.md" + assertEqual + [DanglingFrontmatterPath aId "resource" "references/deleted.md" Nothing] + (strict [danglingResource, conceptB]) + -- §11 forbids rejecting a bundle over a broken cross-link, so nothing is + -- reported outside strict authoring. + assertEqual [] (permissive [danglingResource, conceptB]) + assertEqual [] (strict [resolvedResource, conceptB]) + -- okf has no network access and never fetches, so an absolute URL is as + -- resolved as it gets — whatever its scheme. + assertEqual [] (strict [externalResource, conceptB]) + -- Escaping is deliberately unreported: a bare §4.1 URI such as + -- @analytics.tables.orders@ classifies as a bundle path, so reporting any + -- outcome other than dangling would fire on correct documents. + assertEqual [] (strict [escapingResource, conceptB]) + -- The finding that scoped this check: §5.1 sanctions a scope descriptor as a + -- @sources[].resource@, and @examples\/ddd-ordering@ carries one. Treating it + -- as a path would report a correct bundle as broken. + scopeDescriptor <- + testConceptWithFrontmatter + "a" + ( "type: Test\ntitle: Title\ndescription: Description\n" + <> "generated:\n by: okf/0.4\n at: \"2026-06-16T00:00:00Z\"\n" + <> "sources:\n" + <> " - resource: all order-domain terms agreed in the ordering team's glossary reviews\n" + ) + assertEqual [] (strict [scopeDescriptor, conceptB]) + +-- | The bundle-relative hint of specification §10.2's own worked example: a +-- relative path that resolves to nothing, where the same text read from the +-- bundle root names a file that is there. +-- +-- §6.2 resolution is unchanged — the diagnostic still names what the value +-- actually resolved to. The fourth field only says what the author probably +-- meant. +testDanglingFrontmatterPathAlternative :: Either Text () +testDanglingFrontmatterPathAlternative = do + computationId <- parseTestConceptId "computations/revenue" + rootId <- parseTestConceptId "revenue" + skill <- testConcept "references/skills/run-on-bq" "Run instructions.\n" + let withResource rawId value = + testConceptWithFrontmatter + rawId + ( "type: Test\ntitle: Title\ndescription: Description\n" + <> "generated:\n by: okf/0.4\n at: \"2026-06-16T00:00:00Z\"\n" + <> "resource: " + <> value + <> "\n" + ) + strict concepts = validateInMemoryBundle StrictAuthoring VersionUndeclared concepts + -- The specification's own spelling, from a concept in a subdirectory. + bareReference <- withResource "computations/revenue" "references/skills/run-on-bq.md" + assertEqual + [ DanglingFrontmatterPath + computationId + "resource" + "computations/references/skills/run-on-bq.md" + (Just "references/skills/run-on-bq.md") + ] + (strict [bareReference, skill]) + -- No root-anchored reading resolves either, so there is nothing to suggest. + noTwin <- withResource "computations/revenue" "references/skills/nonexistent.md" + assertEqual + [ DanglingFrontmatterPath + computationId + "resource" + "computations/references/skills/nonexistent.md" + Nothing + ] + (strict [noTwin, skill]) + -- A value already written from the bundle root has no alternative reading. + alreadyAnchored <- withResource "computations/revenue" "/references/skills/deleted.md" + assertEqual + [DanglingFrontmatterPath computationId "resource" "references/skills/deleted.md" Nothing] + (strict [alreadyAnchored, skill]) + -- A concept at the bundle root resolves both readings to the same path, so + -- there is never a hint: either the file is there and nothing is reported, or + -- it is not and the alternative names the same missing path. The guard in + -- 'bundleRelativeAlternative' is what keeps the second case from suggesting + -- exactly what it just rejected. + atRoot <- withResource "revenue" "references/skills/run-on-bq.md" + assertEqual + [DanglingFrontmatterPath rootId "resource" "references/skills/run-on-bq.md" Nothing] + (strict [atRoot]) + assertEqual [] (strict [atRoot, skill]) + +testDuplicateConceptIds :: Either Text () +testDuplicateConceptIds = do + aId <- parseTestConceptId "a" + conceptA <- testConcept "a" "First.\n" + conceptAAgain <- testConcept "a" "Second.\n" + assertEqual [aId] (duplicateConceptIds [conceptA, conceptAAgain]) + +-- | Build an in-memory concept via the public 'conceptFromDocument' constructor, +-- so its typed fields are derived from the frontmatter and cannot diverge. +-- Includes all StrictAuthoring fields so per-document validation passes and +-- bundle-level checks can be isolated. +testConcept :: Text -> Text -> Either Text Concept +testConcept rawId bodyText = do + conceptId <- parseTestConceptId rawId + let frontmatterValue = + okfCommon + OkfCommon + { commonType = "Test", + commonTitle = Just "Title", + commonDescription = Just "Description", + commonTimestamp = Just "2026-06-16T00:00:00Z" + } + pure (conceptFromDocument conceptId (OKFDocument frontmatterValue bodyText)) + +-- | Build a concept from raw frontmatter text, for cases where the frontmatter +-- carries families the 'OkfCommon' builder does not cover. +testConceptWithFrontmatter :: Text -> Text -> Either Text Concept +testConceptWithFrontmatter rawId frontmatterText = do + conceptId <- parseTestConceptId rawId + document <- firstShow (parseDocument ("---\n" <> frontmatterText <> "---\n\n# Test\n")) + pure (conceptFromDocument conceptId document) + +testConceptWithTimestamp :: Text -> Text -> Either Text Concept +testConceptWithTimestamp rawId timestamp = do + conceptId <- parseTestConceptId rawId + let frontmatterValue = + okfCommon + OkfCommon + { commonType = "Test", + commonTitle = Just "Title", + commonDescription = Just "Description", + commonTimestamp = Just timestamp + } + pure (conceptFromDocument conceptId (OKFDocument frontmatterValue "# Test\n")) + +testConceptGeneratedProjection :: Either Text () +testConceptGeneratedProjection = do + conceptId <- parseTestConceptId "tables/orders" + document <- + firstShow + ( parseDocument + "---\ntype: BigQuery Table\ngenerated: { by: human:ahormati, at: 2026-06-20T22:53:05Z }\n---\n\n# Orders\n" + ) + let concept = conceptFromDocument conceptId document + assertEqual + (Just (Generated (HumanActor "ahormati") (Just "2026-06-20T22:53:05Z"))) + (conceptGenerated concept) + +testReadGeneratedWithoutActor :: Either Text () +testReadGeneratedWithoutActor = do + -- Section 5.2 makes `by` REQUIRED within `generated`, so a mapping without + -- one is not a Generated. Reading is silent; reporting is validation's job. + withoutBy <- firstShow (parseDocument "---\ntype: Recipe\ngenerated: { at: 2026-06-20T22:53:05Z }\n---\nBody\n") + assertEqual Nothing (readGenerated (withoutBy ^. #frontmatter)) + notAMapping <- firstShow (parseDocument "---\ntype: Recipe\ngenerated: human:ahormati\n---\nBody\n") + assertEqual Nothing (readGenerated (notAMapping ^. #frontmatter)) + -- `at` is not required within the mapping. + withoutAt <- firstShow (parseDocument "---\ntype: Recipe\ngenerated: { by: reference_agent/gemini-2.5-pro }\n---\nBody\n") + assertEqual + (Just (Generated (ProducerActor "reference_agent" "gemini-2.5-pro") Nothing)) + (readGenerated (withoutAt ^. #frontmatter)) + +-- | Specification section 5.2 permits `verified` as a list or as a single bare +-- `{ by, at }` mapping, and section 11 makes normalising the bare form to a +-- one-element list a consumer MUST. +testReadVerifiedShapes :: Either Text () +testReadVerifiedShapes = do + let verifiedIn source = readVerified . (^. #frontmatter) <$> firstShow (parseDocument source) + asList <- + verifiedIn + "---\ntype: Recipe\nverified:\n - { by: human:ahormati, at: 2026-06-25T09:00:00Z }\n - { by: process:finance-nightly, at: 2026-06-26T02:00:00Z }\n---\nBody\n" + assertEqual + [ Verification (HumanActor "ahormati") (Just "2026-06-25T09:00:00Z"), + Verification (ProcessActor "finance-nightly") (Just "2026-06-26T02:00:00Z") + ] + asList + bareMapping <- verifiedIn "---\ntype: Recipe\nverified: { by: human:ahormati, at: 2026-06-25T09:00:00Z }\n---\nBody\n" + assertEqual [Verification (HumanActor "ahormati") (Just "2026-06-25T09:00:00Z")] bareMapping + absent <- verifiedIn "---\ntype: Recipe\n---\nBody\n" + assertEqual [] absent + -- An entry without the `by` actor is skipped rather than yielding a partial + -- Verification, mirroring readGenerated. + partial <- verifiedIn "---\ntype: Recipe\nverified:\n - { at: 2026-06-25T09:00:00Z }\n - { by: human:ahormati }\n---\nBody\n" + assertEqual [Verification (HumanActor "ahormati") Nothing] partial + notAMapping <- verifiedIn "---\ntype: Recipe\nverified: human:ahormati\n---\nBody\n" + assertEqual [] notAMapping + +testVerifiedRoundTrip :: Either Text () +testVerifiedRoundTrip = do + let verifications = + [ Verification (HumanActor "ahormati") (Just "2026-06-25T09:00:00Z"), + Verification (ProcessActor "finance-nightly") Nothing + ] + original = OKFDocument (setVerified verifications (setType "Recipe" emptyFrontmatter)) "# Demo\n" + rendered = serializeDocument original + reparsed <- firstShow (parseDocument rendered) + assertEqual verifications (readVerified (reparsed ^. #frontmatter)) + -- A single entry is still written as a list, not as the bare-mapping form. + let single = OKFDocument (setVerified [Verification (HumanActor "ahormati") Nothing] emptyFrontmatter) "# Demo\n" + assertBool + ("single entry not written as a list: " <> serializeDocument single) + (isJust (substringIndex "- by:" (serializeDocument single))) + +testReadStatus :: Either Text () +testReadStatus = do + let statusIn source = readStatus . (^. #frontmatter) <$> firstShow (parseDocument source) + withStatus value = statusIn ("---\ntype: Recipe\nstatus: " <> value <> "\n---\nBody\n") + for_ + [("draft", Draft), ("stable", Stable), ("deprecated", Deprecated)] + (\(text, expected) -> withStatus text >>= assertEqual expected) + -- Section 5.4: "Absent `status` => `stable`." + absent <- statusIn "---\ntype: Recipe\n---\nBody\n" + assertEqual Stable absent + -- Section 11 forbids rejecting for an unexpected optional value, and the + -- original text must survive so renderStatus reproduces it. + unknown <- withStatus "archived" + assertEqual (UnknownStatus "archived") unknown + assertEqual "archived" (renderStatus unknown) + -- Case-sensitive, consistent with the section 7 actor convention. + wrongCase <- withStatus "Stable" + assertEqual (UnknownStatus "Stable") wrongCase + -- renderStatus inverts readStatus on every value it can read back. + for_ + [Draft, Stable, Deprecated, UnknownStatus "archived"] + (\value -> withStatus (renderStatus value) >>= assertEqual value) + +testReadStaleAfter :: Either Text () +testReadStaleAfter = do + let staleAfterIn source = readStaleAfter . (^. #frontmatter) <$> firstShow (parseDocument source) + present <- staleAfterIn "---\ntype: Recipe\nstale_after: 2026-09-23\n---\nBody\n" + assertEqual (Just "2026-09-23") present + absent <- staleAfterIn "---\ntype: Recipe\n---\nBody\n" + assertEqual Nothing absent + -- Read verbatim and not parsed here: a malformed date must survive to be + -- reported by Okf.Trust.staleness rather than vanish on serialization. + malformed <- staleAfterIn "---\ntype: Recipe\nstale_after: not-a-date\n---\nBody\n" + assertEqual (Just "not-a-date") malformed + let built = setStaleAfter "2026-09-23" (setStatus Deprecated emptyFrontmatter) + reparsed <- firstShow (parseDocument (serializeDocument (OKFDocument built "# Demo\n"))) + assertEqual (Just "2026-09-23") (readStaleAfter (reparsed ^. #frontmatter)) + assertEqual Deprecated (readStatus (reparsed ^. #frontmatter)) + +testTrustTier :: Either Text () +testTrustTier = do + let verifiedBy actor = Verification (parseActor actor) (Just "2026-06-25T09:00:00Z") + -- Section 5.3: "No `verified` key => unverified." + assertEqual Unverified (trustTier []) + -- "`verified` by non-`human:` actors only => machine-confirmed." + assertEqual MachineConfirmed (trustTier [verifiedBy "process:finance-nightly"]) + assertEqual MachineConfirmed (trustTier [verifiedBy "reference_agent/gemini-2.5-pro"]) + -- An actor matching none of the three section 7 shapes is still not a human. + assertEqual MachineConfirmed (trustTier [verifiedBy "something"]) + -- "`verified` by a `human:` actor => human-reviewed", including mixed. + assertEqual HumanReviewed (trustTier [verifiedBy "human:ahormati"]) + assertEqual + HumanReviewed + (trustTier [verifiedBy "process:finance-nightly", verifiedBy "human:ahormati"]) + -- The Ord instance runs lowest to highest, as section 5.3 presents them. + assertBool "tiers ordered lowest to highest" (Unverified < MachineConfirmed && MachineConfirmed < HumanReviewed) + +testLatestVerification :: Either Text () +testLatestVerification = do + -- Section 5.2: "'How recently' is the latest `at`." + assertEqual + (Just "2026-06-26T02:00:00Z") + ( latestVerification + [ Verification (HumanActor "ahormati") (Just "2026-06-25T09:00:00Z"), + Verification (ProcessActor "finance-nightly") (Just "2026-06-26T02:00:00Z") + ] + ) + -- Entries without an `at` are skipped rather than losing the whole result. + assertEqual + (Just "2026-06-25T09:00:00Z") + ( latestVerification + [ Verification (ProcessActor "nightly") Nothing, + Verification (HumanActor "ahormati") (Just "2026-06-25T09:00:00Z") + ] + ) + assertEqual Nothing (latestVerification []) + assertEqual Nothing (latestVerification [Verification (HumanActor "ahormati") Nothing]) + +testStaleness :: Either Text () +testStaleness = do + let today = fromGregorian 2026 6 15 + assertEqual NoStaleAfter (staleness today Nothing) + -- Section 5.5: "A concept is stale when `today >= stale_after`." + assertEqual (Stale (fromGregorian 2026 6 1)) (staleness today (Just "2026-06-01")) + -- The boundary: equal to today is stale, not fresh. An off-by-one here is a + -- real bug, so it is asserted explicitly. + assertEqual (Stale (fromGregorian 2026 6 15)) (staleness today (Just "2026-06-15")) + assertEqual Fresh (staleness today (Just "2026-06-16")) + assertEqual Fresh (staleness today (Just "2026-09-23")) + -- A malformed deadline is surfaced, never silently treated as fresh. + assertEqual (StaleAfterUnparseable "not-a-date") (staleness today (Just "not-a-date")) + assertEqual (StaleAfterUnparseable "2026-13-01") (staleness today (Just "2026-13-01")) + assertEqual "stale since 2026-06-01" (renderStaleness (staleness today (Just "2026-06-01"))) + assertEqual "ok" (renderStaleness (staleness today (Just "2026-09-23"))) + +-- | A document exercising both usage-window scopes, both credibility-signal +-- shapes, a scope-descriptor resource, and an entry missing the one key +-- section 5.1 requires within an entry. +sourcesFixtureDocument :: Text +sourcesFixtureDocument = + Text.unlines + [ "---", + "type: BigQuery Table", + "sources:", + " - id: ga4-schema", + " resource: https://developers.google.com/analytics/bigquery/export-schema", + " title: GA4 BigQuery Export schema", + " author: team:ga4-docs", + " usage_count: 5000", + " last_modified: 2026-05-30", + " - id: exec-dash", + " resource: dashboards/exec-revenue", + " usage_count: 12", + " usage_window: { from: 2026-01-01, to: 2026-01-31 }", + " - id: broad-scope", + " resource: all queries in BigQuery project X", + " usage_count: \"5000\"", + " - id: no-resource", + " title: Missing the required key", + "usage_window: { from: 2026-06-01, to: 2026-06-30 }", + "---", + "", + "# Orders" + ] + +-- | Specification §5.1 makes the footnote label the join key into @sources@, so +-- strict validation checks it in both directions: a label naming no entry is a +-- defect, and an entry whose id nothing cites is a lint. Neither fires in +-- permissive mode, because §11 forbids rejecting a bundle over optional +-- frontmatter. +testFootnoteAttributionJoin :: Either Text () +testFootnoteAttributionJoin = do + let document mistyped = + Text.unlines + [ "---", + "type: BigQuery Table", + "title: Orders", + "description: Order fact table.", + "generated: { by: okf-agent/1.0, at: 2026-07-31T00:00:00Z }", + "sources:", + " - id: ga4-schema", + " resource: https://developers.google.com/analytics/bigquery/export-schema", + " - id: uncited-policy", + " resource: https://wiki.acme/finance/revenue-recognition", + "---", + "", + "Sharded daily.[^" <> mistyped <> "]", + "", + "[^" <> mistyped <> "]: GA4 BigQuery Export schema" + ] + mistypedDocument <- firstShow (parseDocument (document "ga4-schmea")) + assertEqual + [ FootnoteLabelNotInSources "ga4-schmea", + SourceIdNotCited "ga4-schema", + SourceIdNotCited "uncited-policy" + ] + (validateDocument StrictAuthoring mistypedDocument) + assertEqual [] (validateDocument PermissiveConformance mistypedDocument) + -- Correcting the citation clears the defect and one of the two lints. + correctedDocument <- firstShow (parseDocument (document "ga4-schema")) + assertEqual + [SourceIdNotCited "uncited-policy"] + (validateDocument StrictAuthoring correctedDocument) + +-- | Markdown footnotes are ordinary prose used for ordinary purposes. A document +-- that has not opted into structured provenance is making no attribution claim, +-- so a body full of footnotes must report nothing in either mode. +testFootnoteAttributionSkippedWithoutSources :: Either Text () +testFootnoteAttributionSkippedWithoutSources = do + document <- + firstShow + ( parseDocument + ( Text.unlines + [ "---", + "type: BigQuery Table", + "title: Orders", + "description: Order fact table.", + "generated: { by: okf-agent/1.0, at: 2026-07-31T00:00:00Z }", + "---", + "", + "An aside.[^aside] Another.[^undefined]", + "", + "[^aside]: just a footnote, not an attribution" + ] + ) + ) + assertEqual [] (validateDocument StrictAuthoring document) + assertEqual [] (validateDocument PermissiveConformance document) + +testReadSources :: Either Text () +testReadSources = do + document <- firstShow (parseDocument sourcesFixtureDocument) + let sources = readSources (document ^. #frontmatter) + -- The entry with no `resource` is skipped: section 5.1 makes it REQUIRED + -- within an entry, and reporting it is validation's job, not the reader's. + assertEqual [Just "ga4-schema", Just "exec-dash", Just "broad-scope"] (map sourceId sources) + case sources of + (first_ : _) -> do + assertEqual "https://developers.google.com/analytics/bigquery/export-schema" (sourceResource first_) + assertEqual (Just "GA4 BigQuery Export schema") (sourceTitle first_) + -- `author` uses the section 7 actor convention; `team:ga4-docs` matches + -- none of the three shapes, so it stays unclassified rather than failing. + assertEqual (Just (UnclassifiedActor "team:ga4-docs")) (sourceAuthor first_) + assertEqual (Just 5000) (sourceUsageCount first_) + assertEqual (Just "2026-05-30") (sourceLastModified first_) + [] -> Left "expected sources" + -- Section 5.1 permits a resource to be a population or scope descriptor no + -- consumer can follow. It must read cleanly and never be treated as a path. + assertEqual + (Just "all queries in BigQuery project X") + (sourceResource <$> List.find ((== Just "broad-scope") . sourceId) sources) + -- A numeric string is not an integer. Reading it as one would make the + -- field's type unpredictable and hide a producer mistake. + assertEqual + (Just Nothing) + (sourceUsageCount <$> List.find ((== Just "broad-scope") . sourceId) sources) + absent <- firstShow (parseDocument "---\ntype: Recipe\n---\nBody\n") + assertEqual [] (readSources (absent ^. #frontmatter)) + +testUsageWindowOverride :: Either Text () +testUsageWindowOverride = do + document <- firstShow (parseDocument sourcesFixtureDocument) + let documentWindow = readUsageWindow (document ^. #frontmatter) + sources = readSources (document ^. #frontmatter) + windowFor entryId = + effectiveUsageWindow documentWindow <$> List.find ((== Just entryId) . sourceId) sources + assertEqual (Just (UsageWindow (Just "2026-06-01") (Just "2026-06-30"))) documentWindow + -- An entry with no window of its own inherits the document-scope one... + assertEqual (Just (Just (UsageWindow (Just "2026-06-01") (Just "2026-06-30")))) (windowFor "ga4-schema") + -- ...and an entry carrying its own overrides it. Two different windows in one + -- document is the section 5.1 override rule working. + assertEqual (Just (Just (UsageWindow (Just "2026-01-01") (Just "2026-01-31")))) (windowFor "exec-dash") + -- With no window at either scope there is nothing to frame a count with. + noWindow <- firstShow (parseDocument "---\ntype: Recipe\nsources:\n - resource: https://example.com/a\n---\nBody\n") + let noWindowSources = readSources (noWindow ^. #frontmatter) + assertEqual Nothing (readUsageWindow (noWindow ^. #frontmatter)) + assertEqual [Nothing] (effectiveUsageWindow Nothing <$> noWindowSources) + +testSourcesRoundTrip :: Either Text () +testSourcesRoundTrip = do + let sources = + [ Source + { sourceId = Just "ga4-schema", + sourceResource = "https://developers.google.com/analytics/bigquery/export-schema", + sourceTitle = Just "GA4 BigQuery Export schema", + sourceAuthor = Just (parseActor "human:ahormati"), + sourceUsageCount = Just 5000, + sourceLastModified = Just "2026-05-30", + sourceUsageWindow = Nothing + }, + -- Every optional key absent: these must be omitted on write, not + -- written as explicit nulls, so the round-trip is lossless. + Source + { sourceId = Nothing, + sourceResource = "all queries in BigQuery project X", + sourceTitle = Nothing, + sourceAuthor = Nothing, + sourceUsageCount = Nothing, + sourceLastModified = Nothing, + sourceUsageWindow = Just (UsageWindow (Just "2026-01-01") Nothing) + } + ] + window = UsageWindow (Just "2026-06-01") (Just "2026-06-30") + built = setUsageWindow window (setSources sources (setType "BigQuery Table" emptyFrontmatter)) + reparsed <- firstShow (parseDocument (serializeDocument (OKFDocument built "# Orders\n"))) + assertEqual sources (readSources (reparsed ^. #frontmatter)) + assertEqual (Just window) (readUsageWindow (reparsed ^. #frontmatter)) + +-- | Specification §10.2's worked example, verbatim. Flow-style mappings and a +-- flow-style @receipt@ list are exactly how the specification writes it, which +-- is why they are here: a reader that only handles block style would pass a +-- hand-normalized fixture and fail on the document an author copied out of §10. +attestedComputationFixtureDocument :: Text +attestedComputationFixtureDocument = + Text.unlines + [ "---", + "type: Attested Computation", + "title: Revenue for fiscal year", + "description: Recognized revenue for a fiscal year, per Finance's definition.", + "status: stable", + "runtime: bigquery", + "parameters:", + " - { name: year, type: integer, required: true }", + "executor:", + " resource: references/skills/run-on-bq.md", + " receipt: [job_id, executed_sql, result]", + "attester:", + " resource: references/attesters/revenue.py", + "generated: { by: reference_agent/gemini-2.5-pro, at: 2026-06-20T22:53:05Z }", + "verified: { by: human:ahormati, at: 2026-06-25T09:00:00Z }", + "stale_after: 2026-09-23", + "sources:", + " - id: rev-policy", + " resource: https://wiki.acme/finance/revenue-recognition", + " title: Revenue recognition policy", + "---", + "", + "# Computation", + "", + " SELECT SUM(amount) AS revenue FROM finance.recognized_revenue WHERE fiscal_year = @year" + ] + +-- | The five §10.2 contract fields read off the specification's own worked +-- example. The trust and provenance families in the same frontmatter block are +-- asserted too: §10.2 puts them there deliberately, and reading the contract +-- must not disturb them. +testReadAttestedComputationContract :: Either Text () +testReadAttestedComputationContract = do + document <- firstShow (parseDocument attestedComputationFixtureDocument) + let frontmatterValue = document ^. #frontmatter + assertEqual (Just "bigquery") (readRuntime frontmatterValue) + assertEqual + [Parameter {parameterName = "year", parameterType = Just "integer", parameterRequired = Just True}] + (readParameters frontmatterValue) + -- Absent: §10.3 says an absent `computation` means the body fence is the + -- computation. Reading the body is a sibling plan's job. + assertEqual Nothing (readComputation frontmatterValue) + assertEqual + ( Just + Executor + { executorResource = Just "references/skills/run-on-bq.md", + executorReceipt = ["job_id", "executed_sql", "result"] + } + ) + (readExecutor frontmatterValue) + assertEqual (Just (Attester (Just "references/attesters/revenue.py"))) (readAttester frontmatterValue) + -- The §5 families sharing the block still read exactly as before. + assertEqual + (Just (Generated (parseActor "reference_agent/gemini-2.5-pro") (Just "2026-06-20T22:53:05Z"))) + (readGenerated frontmatterValue) + assertEqual [Verification (parseActor "human:ahormati") (Just "2026-06-25T09:00:00Z")] (readVerified frontmatterValue) + assertEqual Stable (readStatus frontmatterValue) + assertEqual (Just "2026-09-23") (readStaleAfter frontmatterValue) + assertEqual [Just "rev-policy"] (map sourceId (readSources frontmatterValue)) + +-- | Every degenerate contract shape yields a value rather than an error. +-- Specification §11 forbids rejecting a document for a malformed optional +-- field, so the readers are total and reporting is validation's job. +testReadAttestedComputationDegenerateShapes :: Either Text () +testReadAttestedComputationDegenerateShapes = do + let readAll source = do + document <- firstShow (parseDocument source) + pure (document ^. #frontmatter) + -- Nothing declared at all. + bare <- readAll "---\ntype: Attested Computation\n---\nBody\n" + assertEqual Nothing (readRuntime bare) + assertEqual [] (readParameters bare) + assertEqual Nothing (readComputation bare) + assertEqual Nothing (readExecutor bare) + assertEqual Nothing (readAttester bare) + -- `parameters` present but not a list, and `runtime` present but not text. + wrongShapes <- + readAll + ( Text.unlines + [ "---", + "type: Attested Computation", + "runtime: { name: bigquery }", + "parameters: year", + "computation: [a, b]", + "---", + "Body" + ] + ) + assertEqual Nothing (readRuntime wrongShapes) + assertEqual [] (readParameters wrongShapes) + assertEqual Nothing (readComputation wrongShapes) + -- An entry with no `name` names no hole and is dropped, exactly as + -- `readSources` drops an entry with no `resource`. A `required` written as a + -- string is not a boolean, mirroring `usage_count`'s refusal of "5000". + partialEntries <- + readAll + ( Text.unlines + [ "---", + "type: Attested Computation", + "parameters:", + " - { type: integer, required: true }", + " - { name: year }", + " - { name: region, type: string, required: \"true\" }", + " - not-a-mapping", + "---", + "Body" + ] + ) + assertEqual + [ Parameter {parameterName = "year", parameterType = Nothing, parameterRequired = Nothing}, + Parameter {parameterName = "region", parameterType = Just "string", parameterRequired = Nothing} + ] + (readParameters partialEntries) + -- `executor` as a scalar is not a mapping and is not read; a `receipt` + -- written as a bare string is read as a one-element list, mirroring how §5.2 + -- tolerates a bare `verified` mapping where a list is expected. + scalarExecutor <- readAll "---\ntype: Attested Computation\nexecutor: run-on-bq\nattester: revenue.py\n---\nBody\n" + assertEqual Nothing (readExecutor scalarExecutor) + assertEqual Nothing (readAttester scalarExecutor) + bareReceipt <- + readAll + ( Text.unlines + [ "---", + "type: Attested Computation", + "executor: { receipt: job_id }", + "attester: { note: no resource here }", + "---", + "Body" + ] + ) + assertEqual + (Just Executor {executorResource = Nothing, executorReceipt = ["job_id"]}) + (readExecutor bareReceipt) + -- An `attester` mapping with no `resource` still reads: "declared badly" and + -- "not declared" are different facts and only the reader can keep them apart. + assertEqual (Just (Attester Nothing)) (readAttester bareReceipt) + +-- | The §10.2 worked example survives serialization losslessly, and the +-- normalized form emits the five contract keys in their fixed +-- 'coreFrontmatterFieldOrder' position — between the lifecycle @status@ and the +-- trust @generated@, which is §10.2's own ordering. +-- +-- Byte-identity is asserted against the /normalized/ form rather than against +-- the specification's text, because §10.2 writes flow-style mappings that +-- 'serializeDocument' expands to block style by design. What this pins is that +-- serializing is a fixed point: a bundle regenerated twice yields no diff. +testAttestedComputationRoundTrip :: Either Text () +testAttestedComputationRoundTrip = do + document <- firstShow (parseDocument attestedComputationFixtureDocument) + let normalized = serializeDocument document + reparsed <- firstShow (parseDocument normalized) + assertEqual normalized (serializeDocument reparsed) + -- No contract value was normalized away or rewritten on the way through. + assertEqual (readRuntime (document ^. #frontmatter)) (readRuntime (reparsed ^. #frontmatter)) + assertEqual (readParameters (document ^. #frontmatter)) (readParameters (reparsed ^. #frontmatter)) + assertEqual (readComputation (document ^. #frontmatter)) (readComputation (reparsed ^. #frontmatter)) + assertEqual (readExecutor (document ^. #frontmatter)) (readExecutor (reparsed ^. #frontmatter)) + assertEqual (readAttester (document ^. #frontmatter)) (readAttester (reparsed ^. #frontmatter)) + assertEqual (body document) (body reparsed) + assertEqual + [ "type", + "title", + "description", + "status", + "runtime", + "parameters", + "executor", + "attester", + "generated", + "verified", + "stale_after", + "sources" + ] + (topLevelKeysInEmissionOrder normalized) + +-- | §10.3's two forms, read off one document each and then off a document that +-- wrongly offers both. The reader restates and never enforces, so the +-- both-forms document yields two entries rather than a failure; reporting that +-- is 'validateDocument''s job. +testReadComputationSources :: Either Text () +testReadComputationSources = do + -- The specification's own worked example: no `computation` key, one indented + -- block under `# Computation`. + inline <- firstShow (parseDocument attestedComputationFixtureDocument) + assertEqual + [ComputationInline "SELECT SUM(amount) AS revenue FROM finance.recognized_revenue WHERE fiscal_year = @year\n"] + (readComputationSources inline) + byFile <- + firstShow + ( parseDocument + ( Text.unlines + [ "---", + "type: Attested Computation", + "computation: /references/revenue.sql", + "---", + "", + "# Notes", + "", + "The computation lives in a file, so this body carries no block." + ] + ) + ) + assertEqual [ComputationFile "/references/revenue.sql"] (readComputationSources byFile) + both <- + firstShow + ( parseDocument + ( Text.unlines + [ "---", + "type: Attested Computation", + "computation: /references/revenue.sql", + "---", + "", + "# Computation", + "", + "```sql", + "SELECT 1", + "```" + ] + ) + ) + assertEqual + [ComputationFile "/references/revenue.sql", ComputationInline "SELECT 1\n"] + (readComputationSources both) + -- Type-agnostic: a `# Computation` section on a `Metric` is still a fact about + -- that document. Scoping a report to the one type is `Okf.Validation`'s job. + onMetric <- + firstShow + ( parseDocument + (Text.unlines ["---", "type: Metric", "---", "", "# Computation", "", " SELECT 1"]) + ) + assertEqual [ComputationInline "SELECT 1\n"] (readComputationSources onMetric) + +-- | The top-level frontmatter keys of a serialized document, in the order they +-- were emitted. A top-level key is the only thing that starts in column zero +-- inside the frontmatter fence. +topLevelKeysInEmissionOrder :: Text -> [Text] +topLevelKeysInEmissionOrder serialized = + [ Text.takeWhile (/= ':') line + | line <- frontmatterLines, + not (Text.null line), + Text.isInfixOf ":" line, + Text.head line /= ' ', + Text.head line /= '-' + ] + where + frontmatterLines = + takeWhile (/= "---") (drop 1 (Text.lines serialized)) + +-- | Specification §10.2 marks @runtime@ REQUIRED for @type: Attested +-- Computation@, and nothing else in the contract. The check is strict-only: +-- §11's conformance list has three items and none is a computation field, and +-- §11 separately forbids rejecting a bundle over an unknown @type@ value, so +-- "REQUIRED for this type" binds the producer rather than licensing a consumer +-- to refuse. +testValidateAttestedComputationRuntime :: Either Text () +testValidateAttestedComputationRuntime = do + let errorsFor profile source = validateDocument profile <$> firstShow (parseDocument source) + concept typeValue extraLines = + Text.unlines + ( [ "---", + "type: " <> typeValue, + "title: Revenue", + "description: Recognized revenue for a fiscal year.", + "generated: { by: human:you, at: 2026-08-01T00:00:00Z }" + ] + <> extraLines + <> ["---", "", "# Computation", "", " SELECT 1"] + ) + -- A complete contract is clean under both profiles. + complete <- errorsFor StrictAuthoring (concept "Attested Computation" ["runtime: bigquery"]) + assertEqual [] complete + -- No runtime: exactly one problem, and only under strict. + missing <- errorsFor StrictAuthoring (concept "Attested Computation" []) + assertEqual [AttestedComputationMissingRuntime] missing + permissive <- errorsFor PermissiveConformance (concept "Attested Computation" []) + assertEqual [] permissive + -- No other type is affected, including a near-miss spelling. §4.1 says types + -- are not registered centrally and consumers must tolerate unknown ones, so + -- the match is on the one literal §10.1 names, case-sensitively. + metric <- errorsFor StrictAuthoring (concept "Metric" []) + assertEqual [] metric + nearMiss <- errorsFor StrictAuthoring (concept "attested computation" []) + assertEqual [] nearMiss + -- An empty or whitespace runtime declares nothing. + blank <- errorsFor StrictAuthoring (concept "Attested Computation" ["runtime: \" \""]) + assertEqual [AttestedComputationMissingRuntime] blank + +testValidateSources :: Either Text () +testValidateSources = do + let strictErrors source = validateDocument StrictAuthoring <$> firstShow (parseDocument source) + permissiveErrors source = validateDocument PermissiveConformance <$> firstShow (parseDocument source) + preamble = + Text.unlines + [ "---", + "type: BigQuery Table", + "title: Orders", + "description: Order fact table.", + "generated: { by: human:ahormati, at: 2026-06-20T22:53:05Z }" + ] + broken = + preamble + <> Text.unlines + [ "sources:", + " - id: ga4-schema", + " resource: https://example.com/ga4", + " - id: no-resource", + " title: Missing the required key", + " - id: ga4-schema", + " resource: https://example.com/ga4-again", + "---", + "", + "# Orders" + ] + errors <- strictErrors broken + -- The index is the position in the raw YAML list, which is what a person sees + -- in the file, not the position in the list readSources returns. + assertEqual [SourceMissingResource 1, DuplicateSourceId "ga4-schema"] errors + -- Section 11 forbids rejecting a bundle over an optional family, so neither + -- diagnostic may fire permissively. + permissive <- permissiveErrors broken + assertEqual [] permissive + -- A well-formed sources list, including a scope-descriptor resource that no + -- consumer can follow, is clean. Section 5.1 explicitly permits that shape. + clean <- + strictErrors + ( preamble + <> Text.unlines + [ "sources:", + " - id: ga4-schema", + " resource: https://example.com/ga4", + " - resource: all queries in BigQuery project X", + "---", + "", + "# Orders" + ] + ) + assertEqual [] clean + -- A document with no sources at all stays valid in strict mode. + noSources <- strictErrors (preamble <> "---\n\n# Orders\n") + assertEqual [] noSources + +testConceptFromDocumentDerivesFields :: Either Text () +testConceptFromDocumentDerivesFields = do + conceptId <- parseTestConceptId "tables/orders" + let frontmatterValue = + okfCommon + OkfCommon + { commonType = "BigQuery Table", + commonTitle = Just "Orders", + commonDescription = Nothing, + commonTimestamp = Nothing + } + concept = conceptFromDocument conceptId (OKFDocument frontmatterValue "# Orders\n") + assertEqual "BigQuery Table" (conceptType concept) + assertEqual (Just "Orders") (conceptTitle concept) + assertEqual "tables/orders.md" (conceptSourcePath concept) + +testWriteBundleRoundTrip :: IO (Either Text ()) +testWriteBundleRoundTrip = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-core-writebundle" + let buildConcepts = do + orders <- testConcept "tables/orders" "# Orders\n\nOrder records.\n" + customers <- testConcept "tables/customers" "# Customers\n\nCustomer records.\n" + pure [orders, customers] + case buildConcepts of + Left message -> do + removeDirectoryRecursive root + pure (Left message) + Right concepts -> do + writeBundle root concepts + recovered <- readBundle root + removeDirectoryRecursive root + pure + ( do + assertEqual + (List.sort (renderConceptId . conceptIdOf <$> concepts)) + (List.sort (renderConceptId . conceptIdOf <$> recovered)) + assertEqual + (List.sort ((body . conceptDocument) <$> concepts)) + (List.sort ((body . conceptDocument) <$> recovered)) + ) + +testFixtureDanglingLink :: IO (Either Text ()) +testFixtureDanglingLink = do + root <- fixturePath "invalid-dangling-link" + concepts <- readBundle root + inventory <- readBundleInventory root + pure + ( case validateBundle PermissiveConformance VersionUndeclared inventory concepts of + errs + | any isDangling errs -> Right () + | otherwise -> Left ("expected a DanglingReference, got: " <> Text.pack (show errs)) + ) + where + isDangling DanglingReference {} = True + isDangling _ = False + +-- | The §6.2 path check against a real directory rather than an in-memory +-- bundle, which is the only way to exercise the half that needs a filesystem: +-- @non-markdown.md@ names @references\/attesters\/revenue.py@, and that resolves +-- only because 'walkBundleInventory' sees files 'walkBundle' filters out. +-- +-- @computations\/spec-spelling.md@ is the same text written from a +-- subdirectory, which is specification §10.2's own spelling and the one shape +-- that carries a bundle-relative hint. +testFixtureDanglingFrontmatterPath :: IO (Either Text ()) +testFixtureDanglingFrontmatterPath = do + root <- fixturePath "dangling-frontmatter-path" + concepts <- readBundle root + inventory <- readBundleInventory root + pure + ( do + danglingId <- firstShow (parseConceptId "dangling") + specSpellingId <- firstShow (parseConceptId "computations/spec-spelling") + assertEqual 4 (length concepts) + assertEqual + [ DanglingFrontmatterPath + specSpellingId + "resource" + "computations/references/attesters/revenue.py" + (Just "references/attesters/revenue.py"), + DanglingFrontmatterPath danglingId "resource" "references/deleted.txt" Nothing + ] + (validateBundle StrictAuthoring (VersionDeclared (OkfVersion 0 2)) inventory concepts) + assertEqual + [] + (validateBundle PermissiveConformance (VersionDeclared (OkfVersion 0 2)) inventory concepts) + ) + +-- | A whole bundle carrying specification §10.2's contract and §10.3's +-- exactly-one rule, checked end to end. +-- +-- Four things this proves that the document-level tests cannot. The §10.2 and +-- §10.3 checks fire on exactly the concepts that get them wrong and leave the +-- @Metric@ and the @references\/@ concept alone — @metrics\/revenue@ +-- carries no computation at all and is reported by none of them, which is what +-- proves the checks are keyed on the one @type@. Both of the completed +-- computation's path-valued contract fields resolve, including the non-Markdown +-- @revenue.py@ — which only works because 'walkBundleInventory' records every +-- file rather than only the concepts. @computations\/both-computations@ names a +-- @computation@ path that resolves, so its only diagnostic is the §10.3 +-- ambiguity and not a dangling path. And permissive validation reports nothing +-- at all, because §11's conformance list reaches none of this. +testFixtureAttestedComputation :: IO (Either Text ()) +testFixtureAttestedComputation = do + root <- fixturePath "attested-computation" + concepts <- readBundle root + inventory <- readBundleInventory root + pure + ( do + marginId <- firstShow (parseConceptId "computations/margin") + revenueId <- firstShow (parseConceptId "computations/revenue") + bothId <- firstShow (parseConceptId "computations/both-computations") + noneId <- firstShow (parseConceptId "computations/no-computation") + twoBlocksId <- firstShow (parseConceptId "computations/two-blocks") + -- Six computations, one metric, and the one `references/` file that + -- `walkBundle` treats as a concept because it is non-reserved Markdown. + -- The `.py` and `.sql` under `references/` are files and not concepts. + -- + -- The sixth computation, `computations/churn`, deliberately produces no + -- diagnostic here. It is core-clean and deviates only from the house + -- profile in `profiles/attested-computation-house.dhall`, which is what + -- makes this bundle exercise both layers rather than only this one. + assertEqual 8 (length concepts) + assertEqual + [ DocumentInvalid bothId AttestedComputationHasBothComputations, + DocumentInvalid marginId AttestedComputationMissingRuntime, + DocumentInvalid noneId AttestedComputationHasNoComputation, + DocumentInvalid twoBlocksId (AttestedComputationHasManyBlocks 2) + ] + (validateBundle StrictAuthoring (VersionDeclared (OkfVersion 0 2)) inventory concepts) + assertEqual + [] + (validateBundle PermissiveConformance (VersionDeclared (OkfVersion 0 2)) inventory concepts) + -- The contract projected onto the concept, which is what every command + -- reads rather than reaching back into raw frontmatter. + revenue <- maybe (Left "expected computations/revenue") Right (findConcept revenueId concepts) + assertEqual (Just "bigquery") (conceptRuntime revenue) + assertEqual ["year"] (parameterName <$> conceptParameters revenue) + assertEqual Nothing (conceptComputation revenue) + assertEqual + (Just "/references/skills/run-on-bq.md") + (executorResource =<< conceptExecutor revenue) + assertEqual (Just ["job_id", "executed_sql", "result"]) (executorReceipt <$> conceptExecutor revenue) + assertEqual (Just "/references/attesters/revenue.py") (attesterResource =<< conceptAttester revenue) + -- The body half of §10.3, projected alongside the frontmatter half: this + -- concept names no `computation` path, so its one computation is the + -- indented block under `# Computation`. + assertEqual + [ ComputationInline + "SELECT SUM(amount) AS revenue\nFROM finance.recognized_revenue\nWHERE fiscal_year = @year\n" + ] + (conceptComputationSources revenue) + ) + +-- | Resolve a fixture file path regardless of whether tests run from the repo +-- root or the package directory (mirrors 'fixturePath' for files). +fixtureFilePath :: FilePath -> IO FilePath +fixtureFilePath name = findExisting candidates + where + candidates = + [ "okf-core" "test" "fixtures" name, + "test" "fixtures" name + ] + findExisting [] = fail ("fixture file not found: " <> name) + findExisting (candidate : rest) = do + exists <- doesFileExist candidate + if exists then pure candidate else findExisting rest + +-- | Milestone 1: the Dhall descriptor round-trips into a 'ProfileSpec'. +testLoadProfileFixture :: IO (Either Text ()) +testLoadProfileFixture = do + path <- fixtureFilePath "profiles/postgresql.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load profile: " <> err) + Right spec -> do + assertEqual "shinzui-postgresql" (spec ^. #name) + assertEqual + (Just "Conventions for documenting a PostgreSQL database as an OKF bundle.") + (spec ^. #description) + assertEqual False (spec ^. #allowUnknownTypes) + assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) + assertEqual + [ Just "The OKF concept type; must be one of the type rules below.", + Just "Human-readable name of the object, as a reader would say it." + ] + (map (^. #description) (spec ^. #frontmatter . #required)) + -- `timestamp` is written with bare record completion, so it carries no prose. + assertEqual + [ Just "One or two sentences on what this object is for.", + Nothing, + Just "postgresql:// URI locating the live object." + ] + (map (^. #description) (spec ^. #frontmatter . #recommended)) + assertEqual + ["PostgreSQL Schema", "PostgreSQL Table", "PostgreSQL View"] + (map (^. #type_) (spec ^. #types)) + assertEqual + (Just "One physical table in a schema, including its column list.") + (spec ^. #types . to (!! 1) . #description) + +testLoadDocumentIdProfileFixture :: IO (Either Text ()) +testLoadDocumentIdProfileFixture = do + path <- fixtureFilePath "profiles/decisions.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load document ID profile: " <> err) + Right spec -> do + assertEqual (Just "docId") (spec ^. #idField) + assertEqual [Just "ADR"] (map (^. #idPrefix) (spec ^. #types)) + -- Written with the mk/FieldRule.dhall constructors, which normalize to + -- exactly what record completion produces. + assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) + assertEqual + [Just "The OKF concept type; must be a type rule below.", Nothing] + (map (^. #description) (spec ^. #frontmatter . #required)) + +testLoadDescribedProfileFixture :: IO (Either Text ()) +testLoadDescribedProfileFixture = do + path <- fixtureFilePath "profiles/described.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load described profile: " <> err) + Right spec -> do + assertEqual "described" (spec ^. #name) + assertEqual ["Described Concept"] (map (^. #type_) (spec ^. #types)) + assertEqual [emptyTestFrontmatterRules] (map (^. #frontmatter) (spec ^. #types)) + assertEqual True (spec ^. #allowUnknownFields) + assertEqual [[]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) + assertEqual [Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + +testLoadTypeAwareCompatibilityFixture :: IO (Either Text ()) +testLoadTypeAwareCompatibilityFixture = do + path <- fixtureFilePath "profiles/type-aware-ep1.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load EP-1 profile: " <> err) + Right spec -> do + assertEqual "type-aware-ep1" (spec ^. #name) + assertEqual True (spec ^. #allowUnknownFields) + assertEqual [[]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) + assertEqual [[[]]] (map (map (^. #allowedValues) . (^. #frontmatter . #required)) (spec ^. #types)) + assertEqual [Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + +testLoadVocabularyCompatibilityFixture :: IO (Either Text ()) +testLoadVocabularyCompatibilityFixture = do + path <- fixtureFilePath "profiles/vocabulary-ep2.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load EP-2 profile: " <> err) + Right spec -> do + assertEqual "vocabulary-ep2" (spec ^. #name) + assertEqual False (spec ^. #allowUnknownFields) + assertEqual [[], ["draft", "accepted"]] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) + assertEqual [Any, Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + assertEqual [Nothing, Nothing] (map (^. #format) (spec ^. #frontmatter . #required)) + +testLoadCardinalityCompatibilityFixture :: IO (Either Text ()) +testLoadCardinalityCompatibilityFixture = do + path <- fixtureFilePath "profiles/cardinality-ep3.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load EP-3 profile: " <> err) + Right spec -> do + assertEqual "cardinality-ep3" (spec ^. #name) + assertEqual False (spec ^. #allowUnknownFields) + assertEqual [Any, Scalar] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + assertEqual [Nothing, Nothing] (map (^. #format) (spec ^. #frontmatter . #required)) + +testLoadFormatCompatibilityFixture :: IO (Either Text ()) +testLoadFormatCompatibilityFixture = do + path <- fixtureFilePath "profiles/formats-ep4.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load EP-4 profile: " <> err) + Right spec -> do + assertEqual "formats-ep4" (spec ^. #name) + assertEqual [Any, Scalar] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + assertEqual [Nothing, Just Rfc3339Utc] (map (^. #format) (spec ^. #frontmatter . #required)) + assertEqual [Nothing, Nothing] (map (^. #elementFields) (spec ^. #frontmatter . #required)) + +testLoadNestedReviewsProfileFixture :: IO (Either Text ()) +testLoadNestedReviewsProfileFixture = do + path <- fixtureFilePath "profiles/nested-reviews.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load nested review profile: " <> err) + Right spec -> + case [rules | rule <- spec ^. #frontmatter . #required, rule ^. #field == "reviews", Just rules <- [rule ^. #elementFields]] of + [NestedRules {required, recommended}] -> do + assertEqual ["kind", "reviewer", "reviewed_at", "document_timestamp", "scope", "outcome", "context"] (map (^. #field) required) + assertEqual ["notes"] (map (^. #field) recommended) + _ -> Left "expected exactly one reviews rule with elementFields" + +testLoadNestedCompatibilityFixture :: IO (Either Text ()) +testLoadNestedCompatibilityFixture = do + path <- fixtureFilePath "profiles/nested-reviews-ep1.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen nested profile: " <> err) + Right spec -> + case spec ^. #frontmatter . #required of + [rule] -> do + assertEqual Nothing (rule ^. #when) + case rule ^. #elementFields of + Just NestedRules {required = [nestedRule]} -> do + assertEqual "kind" (nestedRule ^. #field) + assertEqual Nothing (nestedRule ^. #when) + _ -> Left "expected the frozen nested rule to survive the compatibility upgrade" + _ -> Left "expected one frozen top-level rule" + +testLoadConditionalFieldsProfileFixture :: IO (Either Text ()) +testLoadConditionalFieldsProfileFixture = do + path <- fixtureFilePath "profiles/conditional-fields.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load conditional profile: " <> err) + Right spec -> do + assertEqual "conditional-fields" (spec ^. #name) + compiled <- firstShow (compileProfile spec) + assertEqual spec (compiledProfileSpec compiled) + +testLoadConditionalCompatibilityFixture :: IO (Either Text ()) +testLoadConditionalCompatibilityFixture = do + path <- fixtureFilePath "profiles/conditional-fields-ep2.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen condition-aware profile: " <> err) + Right spec -> + case spec ^. #frontmatter . #required of + [sourceRule, targetRule, reviewsRule] -> do + assertEqual Nothing (sourceRule ^. #reference) + assertEqual (Just (FieldCondition "status" ["superseded"])) (targetRule ^. #when) + assertEqual Nothing (targetRule ^. #reference) + case reviewsRule ^. #elementFields of + Just NestedRules {required = [_kindRule, providerRule]} -> + assertEqual (Just (FieldCondition "kind" ["model"])) (providerRule ^. #when) + _ -> Left "expected frozen nested conditions to survive the compatibility upgrade" + _ -> Left "expected three frozen condition-aware top-level rules" + +-- | The immediately preceding generation: a descriptor that spells out the +-- reference-aware record types with no @optional@ list anywhere still loads, +-- keeps every field it did declare, and behaves as though each optional list +-- were empty. +testLoadReferenceCompatibilityFixture :: IO (Either Text ()) +testLoadReferenceCompatibilityFixture = do + path <- fixtureFilePath "profiles/document-references-ep3.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen reference-aware profile: " <> err) + Right spec -> do + assertEqual [] (spec ^. #frontmatter . #optional) + assertEqual [[]] (map (^. #frontmatter . #optional) (spec ^. #types)) + case spec ^. #frontmatter . #recommended of + [referenceRule, conditionRule, reviewsRule] -> do + assertEqual + (Just (HandleReferenceRule "ADR" ["mori"] False)) + (referenceRule ^. #reference) + assertEqual (Just (FieldCondition "status" ["superseded"])) (conditionRule ^. #when) + case reviewsRule ^. #elementFields of + Just NestedRules {required = [kindRule], recommended = [notesRule], optional = nestedOptional} -> do + assertEqual "kind" (kindRule ^. #field) + assertEqual "notes" (notesRule ^. #field) + assertEqual [] (map (^. #field) nestedOptional) + _ -> Left "expected the frozen nested rules to survive with an empty optional list" + _ -> Left "expected three frozen reference-aware recommended rules" + +-- | Every frozen generation fixture must both decode /and/ compile. +-- +-- Decoding alone is the weaker property and was, until this test, the only one +-- asserted: eight of the nine generation tests stopped at 'loadProfileFile'. But +-- the guarantee the frozen chain exists to provide is that a descriptor pinned +-- at any released version keeps /working/, and between decoding and working sits +-- 'compileProfile' — where every 'ProfileDefinitionError' is a way for a +-- descriptor that decoded perfectly to stop working. +-- +-- The gap was not theoretical. A compile-time version check written for this +-- plan rejected ten fixtures at once, and the failures surfaced in unrelated +-- documentation and optional-field tests rather than here, which is a far worse +-- signal. It also let @path-references-mp8-ep3.dhall@ ship in a state where it +-- decoded and could never compile. See +-- @docs\/adr\/11-growing-the-profile-descriptor-language.md@. +testFrozenFixturesCompile :: IO (Either Text ()) +testFrozenFixturesCompile = do + results <- traverse loadAndCompile frozenGenerationFixtures + pure (sequence_ results) + where + loadAndCompile name = do + path <- fixtureFilePath ("profiles/" <> name) + result <- loadProfileFile path + pure $ case result of + Left err -> Left (Text.pack name <> " failed to load: " <> err) + Right spec -> + case compileProfile spec of + Left definitionErrors -> + Left (Text.pack name <> " loads but does not compile: " <> Text.pack (show (toList definitionErrors))) + Right _ -> Right () + +-- | The fixtures that stand for a released descriptor generation, and so must +-- represent something a real pinned descriptor could be. +-- +-- The @*-invalid.dhall@ fixtures are deliberately excluded: they exist to prove +-- a definition error fires. @document-references-ep3.dhall@ is excluded for a +-- different and less happy reason — it declares a profile-scope @when@ condition +-- on @status@ while declaring @status@ only at type scope, so it decodes and has +-- never compiled. That is the same latent defect this test exists to prevent, +-- predating it, and repairing it means changing which rules the fixture declares, +-- which its own test asserts. It is recorded in +-- @docs\/plans\/47-enforce-the-profile-declared-okfversion-and-ship-a-v0-2-reference-profile.md@ +-- rather than fixed speculatively here. +frozenGenerationFixtures :: [FilePath] +frozenGenerationFixtures = + [ "legacy-0.2.dhall", + "described.dhall", + "type-aware-ep1.dhall", + "vocabulary-ep2.dhall", + "cardinality-ep3.dhall", + "formats-ep4.dhall", + "nested-reviews-ep1.dhall", + "conditional-fields-ep2.dhall", + "object-fields-mp8-ep1.dhall", + "formats-mp8-ep2.dhall", + "path-references-mp8-ep3.dhall", + "pre-bundle-version.dhall", + -- Not a frozen generation but a *documented* one: this is the descriptor + -- @docs\/user\/profiles.md@ shows for the specification §10 contract as a + -- house convention. It is listed here so the documented descriptor cannot + -- rot into something that no longer compiles. + "attested-computation-house.dhall" + ] + +-- | The generation frozen immediately before @requireBundleVersion@: a descriptor +-- with no such member still loads, the member arrives as 'Nothing', and every +-- member the frozen descriptor did declare survives the upgrade. The last part is +-- what would catch an upgrade function that dropped a field while adding the new +-- one, which is the failure mode a chain this long invites. +testLoadPreBundleVersionCompatibilityFixture :: IO (Either Text ()) +testLoadPreBundleVersionCompatibilityFixture = do + path <- fixtureFilePath "profiles/pre-bundle-version.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen pre-bundle-version profile: " <> err) + Right spec -> do + assertEqual "pre-bundle-version" (spec ^. #name) + -- The new member, absent from the descriptor, means "demand nothing". + assertEqual Nothing (spec ^. #requireBundleVersion) + -- Everything else survived: prose, settings, and rules at both scopes. + assertEqual (Just "Frozen immediately before requireBundleVersion.") (spec ^. #description) + assertEqual "0.2" (spec ^. #okfVersion) + assertEqual False (spec ^. #allowUnknownTypes) + assertEqual True (spec ^. #allowUnknownFields) + assertEqual (Just "docId") (spec ^. #idField) + assertEqual ["type", "generated"] (map (^. #field) (spec ^. #frontmatter . #required)) + assertEqual + (Just (HandleReferenceRule "ADR" ["mori"] False)) + (case spec ^. #frontmatter . #optional of rule : _ -> rule ^. #reference; [] -> Nothing) + assertEqual + [Just Profile.HumanActor] + (concatMap (map (^. #format) . (^. #frontmatter . #required)) (spec ^. #types)) + assertEqual [Just "ADR"] (map (^. #idPrefix) (spec ^. #types)) + +-- | The generation frozen immediately before path-valued reference rules: a +-- descriptor with no @path@ member on 'FieldRule' or 'NestedFieldRule' still +-- loads, every member it did declare survives at both levels and at both nested +-- shapes, and the new member arrives as 'Nothing' everywhere. The fixture writes +-- out every published type it names, unions included, so widening one cannot +-- quietly turn this into a test of the current decoder. +testLoadPrePathCompatibilityFixture :: IO (Either Text ()) +testLoadPrePathCompatibilityFixture = do + path <- fixtureFilePath "profiles/path-references-mp8-ep3.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen pre-path profile: " <> err) + Right spec -> do + assertEqual "path-references-mp8-ep3" (spec ^. #name) + -- The new member is absent everywhere it can appear: three top-level + -- presence lists, one type scope, and both nested shapes. + assertEqual [Nothing, Nothing, Nothing] (map (^. #path) (spec ^. #frontmatter . #required)) + assertEqual [Nothing] (map (^. #path) (spec ^. #frontmatter . #recommended)) + assertEqual [Nothing] (map (^. #path) (spec ^. #frontmatter . #optional)) + assertEqual + [Nothing] + (concatMap (map (^. #path) . (^. #frontmatter . #required)) (spec ^. #types)) + -- Everything the frozen descriptor did declare survives the upgrade. + assertEqual + (Just (HandleReferenceRule "ADR" ["mori"] False)) + (case spec ^. #frontmatter . #optional of rule : _ -> rule ^. #reference; [] -> Nothing) + assertEqual + [Just Profile.NonNegativeInteger] + (map (^. #format) (spec ^. #frontmatter . #recommended)) + assertEqual + [Just Profile.HumanActor] + (concatMap (map (^. #format) . (^. #frontmatter . #required)) (spec ^. #types)) + case spec ^. #frontmatter . #required of + [_typeRule, sourcesRule, generatedRule] -> do + case sourcesRule ^. #elementFields of + Just NestedRules {required = [resourceRule]} -> do + assertEqual "resource" (resourceRule ^. #field) + assertEqual Scalar (resourceRule ^. #cardinality) + assertEqual Nothing (resourceRule ^. #path) + _ -> Left "expected the frozen element-field rule to survive" + case generatedRule ^. #objectFields of + Just NestedRules {required = [byRule]} -> do + assertEqual "by" (byRule ^. #field) + assertEqual (Just Profile.Actor) (byRule ^. #format) + assertEqual Nothing (byRule ^. #path) + _ -> Left "expected the frozen object-member rule to survive" + _ -> Left "expected three frozen required rules" + +-- | The generation frozen immediately before the OKF v0.2 value formats: a +-- descriptor whose records match today's shape but whose @format@ members are +-- typed by the five-alternative format union still loads, and every format it +-- declared arrives as the corresponding current 'FieldFormat'. The fixture +-- writes the union out as a literal rather than importing +-- @okf-core\/dhall\/FieldFormat.dhall@, so widening that file cannot quietly +-- turn this into a test of the current decoder. +testLoadPreActorCompatibilityFixture :: IO (Either Text ()) +testLoadPreActorCompatibilityFixture = do + path <- fixtureFilePath "profiles/formats-mp8-ep2.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen five-alternative format profile: " <> err) + Right spec -> do + assertEqual "formats-mp8-ep2" (spec ^. #name) + assertEqual + [Nothing, Nothing, Nothing] + (map (^. #format) (spec ^. #frontmatter . #required)) + assertEqual + [Just Rfc3339Utc, Just Date] + (map (^. #format) (spec ^. #frontmatter . #recommended)) + assertEqual + [Just (UriWithScheme "https"), Just (DocumentHandle "ADR"), Just Uri] + (map (^. #format) (spec ^. #frontmatter . #optional)) + assertEqual + [Just Date] + (concatMap (map (^. #format) . (^. #frontmatter . #required)) (spec ^. #types)) + case spec ^. #frontmatter . #required of + [_typeRule, _titleRule, generatedRule] -> + case generatedRule ^. #objectFields of + Just NestedRules {required = [byRule, atRule]} -> do + assertEqual "by" (byRule ^. #field) + assertEqual Nothing (byRule ^. #format) + assertEqual (Just Rfc3339Utc) (atRule ^. #format) + _ -> Left "expected the frozen object members to survive" + _ -> Left "expected three frozen required rules" + +-- | The generation frozen immediately before object rules: a descriptor that +-- spells out the optional-presence record types with no @objectFields@ member +-- anywhere still loads, keeps every field it did declare — including the +-- @optional@ lists at both scopes and one level of @elementFields@ — and +-- behaves as though every rule declared no object shape. +testLoadPreObjectCompatibilityFixture :: IO (Either Text ()) +testLoadPreObjectCompatibilityFixture = do + path <- fixtureFilePath "profiles/object-fields-mp8-ep1.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load frozen optional-presence profile: " <> err) + Right spec -> do + assertEqual "object-fields-mp8-ep1" (spec ^. #name) + assertEqual + [Nothing, Nothing] + (map (^. #objectFields) (spec ^. #frontmatter . #required)) + assertEqual + [Nothing, Nothing] + (map (^. #objectFields) (spec ^. #frontmatter . #recommended)) + assertEqual ["supersededBy"] (map (^. #field) (spec ^. #frontmatter . #optional)) + assertEqual [Nothing] (map (^. #objectFields) (spec ^. #frontmatter . #optional)) + case spec ^. #frontmatter . #recommended of + [referenceRule, reviewsRule] -> do + assertEqual + (Just (HandleReferenceRule "ADR" ["mori"] False)) + (referenceRule ^. #reference) + case reviewsRule ^. #elementFields of + Just NestedRules {required = [kindRule], recommended = [notesRule], optional = [urlRule]} -> do + assertEqual "kind" (kindRule ^. #field) + assertEqual "notes" (notesRule ^. #field) + assertEqual "url" (urlRule ^. #field) + _ -> Left "expected the frozen nested rules to survive with all three presence lists" + _ -> Left "expected two frozen optional-presence recommended rules" + +-- | The backwards-compatibility guarantee: a descriptor frozen in the okf 0.2.x +-- shape — bare-string frontmatter keys, no descriptions anywhere — still loads, +-- via the legacy fallback decoder, with every description absent. +testLoadLegacyProfileFixture :: IO (Either Text ()) +testLoadLegacyProfileFixture = do + path <- fixtureFilePath "profiles/legacy-0.2.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load legacy profile: " <> err) + Right spec -> do + assertEqual "legacy" (spec ^. #name) + assertEqual Nothing (spec ^. #description) + assertEqual ["type", "title"] (map (^. #field) (spec ^. #frontmatter . #required)) + assertEqual [Nothing, Nothing] (map (^. #description) (spec ^. #frontmatter . #required)) + assertEqual ["Legacy Concept"] (map (^. #type_) (spec ^. #types)) + assertEqual [Nothing] (map (^. #description) (spec ^. #types)) + assertEqual True (spec ^. #allowUnknownFields) + assertEqual [[], []] (map (^. #allowedValues) (spec ^. #frontmatter . #required)) + assertEqual [Any, Any] (map (^. #cardinality) (spec ^. #frontmatter . #required)) + +testProfileFieldDescription :: IO (Either Text ()) +testProfileFieldDescription = do + path <- fixtureFilePath "profiles/postgresql.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load profile: " <> err) + Right spec -> do + assertEqual + (Just "Human-readable name of the object, as a reader would say it.") + (profileFieldDescription spec "title") + assertEqual + (Just "postgresql:// URI locating the live object.") + (profileFieldDescription spec "resource") + assertEqual Nothing (profileFieldDescription spec "timestamp") + assertEqual Nothing (profileFieldDescription spec "nope") + +-- | Prose declared on an optional rule is as discoverable as prose on a required +-- or recommended one; the third list is searched last, after the two that can +-- produce a missing-field diagnostic. +testOptionalFieldDescription :: IO (Either Text ()) +testOptionalFieldDescription = do + path <- fixtureFilePath "profiles/decisions.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load decisions profile: " <> err) + Right spec -> + assertEqual + (Just "The decision this one replaces, when it replaces one.") + (profileFieldDescription spec "supersedes") + +-- | The JSON encoding is pinned field by field, so a future refactor cannot +-- silently rename a key. The @type@ key matters most: the Haskell field is +-- @type_@, and consumers must never see that. +testProfileJsonShape :: IO (Either Text ()) +testProfileJsonShape = do + path <- fixtureFilePath "profiles/decisions.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load document ID profile: " <> err) + Right spec -> + assertEqual + ( object + [ "name" .= ("decisions" :: Text), + "description" .= ("How this team records architectural decisions." :: Text), + "okfVersion" .= ("0.1" :: Text), + -- Encoded even when absent, so a consumer reads one shape rather + -- than having to distinguish a missing key from a null one. + "requireBundleVersion" .= (Nothing :: Maybe Text), + "allowUnknownTypes" .= False, + "allowUnknownFields" .= True, + "idField" .= ("docId" :: Text), + "frontmatter" + .= object + [ "required" + .= [ object + [ "field" .= ("type" :: Text), + "description" + .= ("The OKF concept type; must be a type rule below." :: Text), + "allowedValues" .= ([] :: [Text]), + "cardinality" .= ("any" :: Text), + "format" .= (Nothing :: Maybe Text), + "elementFields" .= (Nothing :: Maybe Value), + "objectFields" .= (Nothing :: Maybe Value), + "reference" .= (Nothing :: Maybe HandleReferenceRule), + "path" .= (Nothing :: Maybe PathReferenceRule), + "when" .= (Nothing :: Maybe FieldCondition) + ], + object + [ "field" .= ("title" :: Text), + "description" .= (Nothing :: Maybe Text), + "allowedValues" .= ([] :: [Text]), + "cardinality" .= ("any" :: Text), + "format" .= (Nothing :: Maybe Text), + "elementFields" .= (Nothing :: Maybe Value), + "objectFields" .= (Nothing :: Maybe Value), + "reference" .= (Nothing :: Maybe HandleReferenceRule), + "path" .= (Nothing :: Maybe PathReferenceRule), + "when" .= (Nothing :: Maybe FieldCondition) + ] + ], + "recommended" + .= [ object + [ "field" .= ("status" :: Text), + "description" + .= ("One of: proposed, accepted, superseded." :: Text), + "allowedValues" .= ([] :: [Text]), + "cardinality" .= ("any" :: Text), + "format" .= (Nothing :: Maybe Text), + "elementFields" .= (Nothing :: Maybe Value), + "objectFields" .= (Nothing :: Maybe Value), + "reference" .= (Nothing :: Maybe HandleReferenceRule), + "path" .= (Nothing :: Maybe PathReferenceRule), + "when" .= (Nothing :: Maybe FieldCondition) + ] + ], + "optional" + .= [ object + [ "field" .= ("supersedes" :: Text), + "description" + .= ("The decision this one replaces, when it replaces one." :: Text), + "allowedValues" .= ([] :: [Text]), + "cardinality" .= ("any" :: Text), + "format" .= (Nothing :: Maybe Text), + "elementFields" .= (Nothing :: Maybe Value), + "objectFields" .= (Nothing :: Maybe Value), + "reference" .= (Nothing :: Maybe HandleReferenceRule), + "path" .= (Nothing :: Maybe PathReferenceRule), + "when" .= (Nothing :: Maybe FieldCondition) + ] + ] + ], + "types" + .= [ object + [ "type" .= ("Decision Record" :: Text), + "description" + .= ("One accepted decision, never edited after acceptance." :: Text), + "frontmatter" + .= object + [ "required" .= ([] :: [FieldRule]), + "recommended" .= ([] :: [FieldRule]), + "optional" .= ([] :: [FieldRule]) + ], + "pathPattern" .= ("decisions/*" :: Text), + "resourceScheme" .= (Nothing :: Maybe Text), + "requireSchemaSection" .= False, + "schemaColumns" .= ([] :: [Text]), + "idPrefix" .= ("ADR" :: Text) + ] + ] + ] + ) + (toJSON spec) + +testFieldFormatJsonShape :: Either Text () +testFieldFormatJsonShape = + assertEqual + [ String "rfc3339-utc", + String "date", + String "uri", + object ["uriWithScheme" .= ("mori" :: Text)], + object ["documentHandle" .= ("ADR" :: Text)] + ] + (map toJSON [Rfc3339Utc, Date, Uri, UriWithScheme "mori", DocumentHandle "ADR"]) + +testFieldConditionJsonShape :: Either Text () +testFieldConditionJsonShape = + assertEqual + (object ["field" .= ("status" :: Text), "hasValue" .= (["superseded"] :: [Text])]) + (toJSON (FieldCondition "status" ["superseded"])) + +testHandleReferenceJsonShape :: Either Text () +testHandleReferenceJsonShape = + assertEqual + ( object + [ "localPrefix" .= ("ADR" :: Text), + "externalUriSchemes" .= (["mori", "https"] :: [Text]), + "allowSelf" .= False + ] + ) + (toJSON (HandleReferenceRule "ADR" ["mori", "https"] False)) + +-- | A registry record enumerates every field that decodes as a profile, one +-- level down as well as at the top, sorted by export path. The @Profile@ schema +-- record and the @note@ string contribute nothing. +testRegistryEnumeratesProfiles :: IO (Either Text ()) +testRegistryEnumeratesProfiles = do + path <- fixtureFilePath "registry/package.dhall" + loaded <- loadRegistry (RegistryFile path) + pure $ case loaded of + Left err -> Left ("failed to load fixture registry: " <> err) + Right entries -> do + -- `legacy` is a frozen okf 0.2.x descriptor: it enumerates only because + -- the registry walk falls back to the legacy decoder. + assertEqual ["legacy", "nested.decisions", "postgresql"] (map (^. #export) entries) + case findRegistryEntry "legacy" entries of + Nothing -> Left "expected an entry at export path legacy" + Just entry -> do + assertEqual "legacy" (entry ^. #spec . #name) + assertEqual Nothing (entry ^. #spec . #description) + case findRegistryEntry "postgresql" entries of + Nothing -> Left "expected an entry at export path postgresql" + Just entry -> assertEqual "shinzui-postgresql" (entry ^. #spec . #name) + assertEqual Nothing (findRegistryEntry "nope" entries) + assertBool + "expected findRegistryEntry to resolve the nested export" + (isJust (findRegistryEntry "nested.decisions" entries)) + +-- | A registry reference that is itself a profile yields one entry whose export +-- path is empty. +testRegistryRootProfile :: IO (Either Text ()) +testRegistryRootProfile = do + path <- fixtureFilePath "profiles/decisions.dhall" + loaded <- loadRegistry (RegistryFile path) + pure $ case loaded of + Left err -> Left ("failed to load root profile registry: " <> err) + Right entries -> do + assertEqual [""] (map (^. #export) entries) + assertEqual ["decisions"] (map (^. #spec . #name) entries) + +-- | A directory holding @package.dhall@ resolves to that file; anything else +-- is handed to Dhall verbatim. +testResolveRegistryRef :: IO (Either Text ()) +testResolveRegistryRef = do + directory <- fixturePath "registry" + resolvedDirectory <- resolveRegistryRef (Text.pack directory) + filePath <- fixtureFilePath "profiles/decisions.dhall" + resolvedFile <- resolveRegistryRef (Text.pack filePath) + resolvedExpression <- resolveRegistryRef "./nowhere/at/all.dhall" + pure $ do + assertEqual (RegistryFile (directory "package.dhall")) resolvedDirectory + assertEqual (RegistryFile filePath) resolvedFile + assertEqual (RegistryExpression "./nowhere/at/all.dhall") resolvedExpression + +-- | A reference that cannot be evaluated reports an error rather than throwing. +testRegistryLoadFailure :: IO (Either Text ()) +testRegistryLoadFailure = do + loaded <- loadRegistry (RegistryFile "/nonexistent/registry.dhall") + pure $ case loaded of + Right entries -> Left ("expected a load failure, got " <> Text.pack (show (length entries)) <> " entries") + Left message -> assertBool "expected a non-empty error message" (not (Text.null message)) + +testParseDocumentId :: Either Text () +testParseDocumentId = do + assertEqual + (Just (DocumentId {prefix = "ADR", number = 7})) + (parseDocumentId "ADR-7") + mapM_ + (\invalid -> assertEqual Nothing (parseDocumentId invalid)) + ["ADR-007", "ADR-0", "ADR-", "-7", "ADR 7", "ADR-7-extra"] + assertEqual (Just "ADR-7") (renderDocumentId <$> parseDocumentId "ADR-7") + +testDocumentIdsInBundle :: IO (Either Text ()) +testDocumentIdsInBundle = do + descriptorPath <- fixtureFilePath "profiles/decisions.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "doc-ids" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load document ID profile: " <> err) + Right spec -> do + useMarkdown <- parseTestConceptId "decisions/use-markdown" + usePostgres <- parseTestConceptId "decisions/use-postgres" + adoptOkf <- parseTestConceptId "decisions/adopt-okf" + assertEqual + [ (DocumentId "ADR" 1, useMarkdown), + (DocumentId "ADR" 2, usePostgres), + (DocumentId "ADR" 3, adoptOkf) + ] + (documentIdsInBundle spec concepts) + +testNextDocumentId :: Either Text () +testNextDocumentId = do + firstConcept <- + profileConcept + "decisions/first" + [("type", String "Decision Record"), ("title", String "First"), ("docId", String "ADR-1")] + "# First\n" + thirdConcept <- + profileConcept + "decisions/third" + [("type", String "Decision Record"), ("title", String "Third"), ("docId", String "ADR-3")] + "# Third\n" + let concepts = [firstConcept, thirdConcept] + assertEqual (DocumentId "ADR" 4) (nextDocumentId testDocumentIdProfileSpec concepts "ADR") + assertEqual (DocumentId "RFC" 1) (nextDocumentId testDocumentIdProfileSpec concepts "RFC") + +testFindConceptsByDocumentId :: IO (Either Text ()) +testFindConceptsByDocumentId = do + validRoot <- fixturePath "doc-ids" + validConcepts <- readBundle validRoot + deviationRoot <- fixturePath "doc-id-deviations" + deviationConcepts <- readBundle deviationRoot + pure $ do + usePostgres <- parseTestConceptId "decisions/use-postgres" + firstId <- parseTestConceptId "decisions/first" + secondId <- parseTestConceptId "decisions/second" + assertEqual + [usePostgres] + (conceptIdOf <$> findConceptsByDocumentId Nothing "ADR-2" validConcepts) + assertEqual + [firstId, secondId] + (conceptIdOf <$> findConceptsByDocumentId (Just "docId") "ADR-1" deviationConcepts) + +-- | An undocumented frontmatter key: the validation tests care about names, not +-- prose, and descriptions never affect validation. +requiredField :: Text -> FieldRule +requiredField key = FieldRule {field = key, description = Nothing, allowedValues = [], cardinality = Any, format = Nothing, elementFields = Nothing, objectFields = Nothing, reference = Nothing, path = Nothing, when = Nothing} + +-- | Build a 'FieldRule' positionally in the argument order this file used +-- before 'FieldRule' gained @objectFields@, filling that member in as +-- 'Nothing'. The dozens of call sites below constrain lists, formats, +-- conditions, and references rather than object shapes, so spelling out a ninth +-- 'Nothing' at each of them would add noise and no information. A test that +-- does exercise object rules builds its rule with record syntax instead. +fieldRule :: + Text -> + Maybe Text -> + [Text] -> + Cardinality -> + Maybe FieldFormat -> + Maybe NestedRules -> + Maybe HandleReferenceRule -> + Maybe FieldCondition -> + FieldRule +fieldRule key description allowedValues cardinality format elementFields reference condition = + FieldRule + { field = key, + description, + allowedValues, + cardinality, + format, + elementFields, + objectFields = Nothing, + reference, + path = Nothing, + when = condition + } + +-- | A standalone profile literal so the validation tests do not depend on the +-- Dhall fixture. One rule: PostgreSQL Table, fully constrained. +testProfileSpec :: ProfileSpec +testProfileSpec = + ProfileSpec + { name = "test-postgresql", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [requiredField "type", requiredField "title"], + recommended = [], + optional = [] + }, + allowUnknownTypes = False, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = + [ TypeRule + { type_ = "PostgreSQL Table", + description = Nothing, + frontmatter = emptyTestFrontmatterRules, + pathPattern = Just "schemas/*/tables/*", + resourceScheme = Just "postgresql", + requireSchemaSection = True, + schemaColumns = ["Column", "Type", "Nullable", "Description"], + idPrefix = Nothing + } + ] + } + +testDocumentIdProfileSpec :: ProfileSpec +testDocumentIdProfileSpec = + ProfileSpec + { name = "test-decisions", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [requiredField "type", requiredField "title"], + recommended = [], + optional = [] + }, + allowUnknownTypes = False, + allowUnknownFields = True, + idField = Just "docId", + requireBundleVersion = Nothing, + types = + [ TypeRule + { type_ = "Decision Record", + description = Nothing, + frontmatter = emptyTestFrontmatterRules, + pathPattern = Just "decisions/*", + resourceScheme = Nothing, + requireSchemaSection = False, + schemaColumns = [], + idPrefix = Just "ADR" + } + ] + } + +emptyTestFrontmatterRules :: FrontmatterRules +emptyTestFrontmatterRules = FrontmatterRules {required = [], recommended = [], optional = []} + +typeAwareProfileSpec :: ProfileSpec +typeAwareProfileSpec = + ProfileSpec + { name = "type-aware", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, fieldRule "title" (Just "Global title.") [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "owner" (Just "Profile-level owner.") [] Any Nothing Nothing Nothing Nothing], + optional = [] + }, + allowUnknownTypes = True, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = + [ TypeRule + { type_ = "Owned Concept", + description = Nothing, + frontmatter = + FrontmatterRules + { required = [fieldRule "owner" (Just "Responsible person.") [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "reviewer" (Just "Second pair of eyes.") [] Any Nothing Nothing Nothing Nothing, fieldRule "title" (Just "Type title.") [] Any Nothing Nothing Nothing Nothing], + optional = [] + }, + pathPattern = Nothing, + resourceScheme = Nothing, + requireSchemaSection = False, + schemaColumns = [], + idPrefix = Nothing + } + ] + } + +testCompileProfileDefinitionErrors :: Either Text () +testCompileProfileDefinitionErrors = do + let duplicateField = fieldRule "title" Nothing [] Any Nothing Nothing Nothing Nothing + invalid = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [duplicateField, duplicateField], + recommended = [duplicateField], + optional = [] + }, + types = (typeAwareProfileSpec ^. #types) <> (typeAwareProfileSpec ^. #types) + } + case compileProfile invalid of + Right _ -> Left "expected invalid profile definition" + Left errors -> + assertEqual + [ DuplicateFieldRule Nothing "required" "title", + ConflictingFieldRequirement Nothing "title", + DuplicateTypeRule "Owned Concept" + ] + (toList errors) + +testCompiledProfileMerge :: Either Text () +testCompiledProfileMerge = do + compiled <- firstShow (compileProfile typeAwareProfileSpec) + assertEqual (Just "Type title.") (profileFieldDescriptionForType compiled "Owned Concept" "title") + assertEqual (Just "Responsible person.") (profileFieldDescriptionForType compiled "Owned Concept" "owner") + assertEqual (Just "Global title.") (profileFieldDescriptionForType compiled "Unknown Concept" "title") + concept <- profileConcept "owned/one" [("type", String "Owned Concept")] "# One\n" + cid <- parseTestConceptId "owned/one" + assertEqual + [MissingProfileField cid "owner" Nothing, MissingProfileField cid "title" Nothing] + (validateProfile PermissiveConformance compiled [concept]) + +vocabularyProfileSpec :: ProfileSpec +vocabularyProfileSpec = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "status" Nothing ["draft", "approved", "approved"] Any Nothing Nothing Nothing Nothing], + optional = [] + }, + types = + [ withTypeFrontmatter + FrontmatterRules + { required = [fieldRule "status" Nothing ["approved", "archived"] Any Nothing Nothing Nothing Nothing], + recommended = [], + optional = [] + } + (firstTypeRule typeAwareProfileSpec) + ] + } + +fieldPath :: Text -> FieldPath +fieldPath key = FieldPath (FieldName key :| []) + +testCompiledVocabularyIntersection :: Either Text () +testCompiledVocabularyIntersection = do + compiled <- firstShow (compileProfile vocabularyProfileSpec) + concept <- profileConcept "owned/one" [("type", String "Owned Concept"), ("status", String "draft")] "# One\n" + cid <- parseTestConceptId "owned/one" + assertEqual + [ValueNotInVocabulary cid (fieldPath "status") ["approved"] (String "draft")] + (validateProfile PermissiveConformance compiled [concept]) + +testUnsatisfiableVocabulary :: Either Text () +testUnsatisfiableVocabulary = do + let disjoint = + vocabularyProfileSpec + { types = + [ withTypeFrontmatter + FrontmatterRules + { required = [fieldRule "status" Nothing ["closed"] Any Nothing Nothing Nothing Nothing], + recommended = [], + optional = [] + } + (firstTypeRule vocabularyProfileSpec) + ] + } + assertEqual + (Left (UnsatisfiableVocabulary (Just "Owned Concept") "status" ["draft", "approved"] ["closed"] :| [])) + (compileProfile disjoint) + +testCompiledCardinality :: Either Text () +testCompiledCardinality = do + let profileRules = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "status" Nothing [] Scalar Nothing Nothing Nothing Nothing], + optional = [] + } + typeRules cardinality = + FrontmatterRules + { required = [fieldRule "status" Nothing [] cardinality Nothing Nothing Nothing Nothing], + recommended = [], + optional = [] + } + baseType = firstTypeRule typeAwareProfileSpec + compatible = + typeAwareProfileSpec + { frontmatter = profileRules, + types = [withTypeFrontmatter (typeRules Any) baseType] + } + contradictory = compatible {types = [withTypeFrontmatter (typeRules List) baseType]} + compiled <- firstShow (compileProfile compatible) + valid <- profileConcept "owned/cardinality" [("type", String "Owned Concept"), ("status", Number 3)] "# Valid\n" + invalid <- profileConcept "owned/cardinality" [("type", String "Owned Concept"), ("status", toJSON (["draft"] :: [Text]))] "# Invalid\n" + cid <- parseTestConceptId "owned/cardinality" + assertEqual [] (validateProfile PermissiveConformance compiled [valid]) + assertEqual + [CardinalityMismatch cid (fieldPath "status") Scalar (toJSON (["draft"] :: [Text]))] + (validateProfile PermissiveConformance compiled [invalid]) + assertEqual + (Left (ConflictingCardinality (Just "Owned Concept") "status" Scalar List :| [])) + (compileProfile contradictory) + +testVocabularyValidation :: Either Text () +testVocabularyValidation = do + let openVocabulary = + vocabularyProfileSpec + { frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "status" Nothing ["draft", "approved"] Any Nothing Nothing Nothing Nothing], + optional = [] + }, + types = [] + } + compiled <- firstShow (compileProfile openVocabulary) + validString <- profileConcept "valid-string" [("type", String "Extension"), ("status", String "draft")] "# Valid\n" + validList <- profileConcept "valid-list" [("type", String "Extension"), ("status", toJSON (["draft", "approved"] :: [Text]))] "# Valid\n" + absent <- profileConcept "absent" [("type", String "Extension")] "# Absent\n" + invalidString <- profileConcept "invalid-string" [("type", String "Extension"), ("status", String "banana")] "# Invalid\n" + invalidList <- profileConcept "invalid-list" [("type", String "Extension"), ("status", toJSON (["draft", "banana"] :: [Text]))] "# Invalid\n" + invalidShape <- profileConcept "invalid-shape" [("type", String "Extension"), ("status", toJSON (1 :: Int))] "# Invalid\n" + invalidStringId <- parseTestConceptId "invalid-string" + invalidListId <- parseTestConceptId "invalid-list" + invalidShapeId <- parseTestConceptId "invalid-shape" + assertEqual [] (validateProfile PermissiveConformance compiled [validString, validList, absent]) + assertEqual + [ValueNotInVocabulary invalidStringId (fieldPath "status") ["draft", "approved"] (String "banana")] + (validateProfile PermissiveConformance compiled [invalidString]) + assertEqual + [ValueNotInVocabulary invalidListId (fieldPath "status") ["draft", "approved"] (toJSON (["draft", "banana"] :: [Text]))] + (validateProfile PermissiveConformance compiled [invalidList]) + assertEqual + [ValueNotInVocabulary invalidShapeId (fieldPath "status") ["draft", "approved"] (toJSON (1 :: Int))] + (validateProfile PermissiveConformance compiled [invalidShape]) + +testCardinalityValidation :: Either Text () +testCardinalityValidation = do + cid <- parseTestConceptId "cardinality" + let check cardinality actual = do + compiled <- firstShow (compileProfile (singleCardinalityProfile True cardinality [])) + concept <- profileConcept "cardinality" [("type", String "Extension"), ("value", actual)] "# Cardinality\n" + pure (validateProfile PermissiveConformance compiled [concept]) + mismatch cardinality actual = [CardinalityMismatch cid (fieldPath "value") cardinality actual] + objectValue = object ["nested" .= (True :: Bool)] + textList = toJSON (["one"] :: [Text]) + emptyList = toJSON ([] :: [Text]) + for_ [String "one", Number 0, Bool False] $ \actual -> + check Scalar actual >>= assertEqual [] + for_ [textList, objectValue, Null] $ \actual -> + check Scalar actual >>= assertEqual (mismatch Scalar actual) + check List textList >>= assertEqual [] + for_ [String "one", Number 0, Bool False, objectValue, Null] $ \actual -> + check List actual >>= assertEqual (mismatch List actual) + check Any (String "one") >>= assertEqual [] + check Any textList >>= assertEqual [] + check Any (Bool False) >>= assertEqual [MissingProfileField cid "value" Nothing] + check Scalar (String " ") >>= assertEqual [MissingProfileField cid "value" Nothing] + check List emptyList >>= assertEqual [MissingProfileField cid "value" Nothing] + optionalCompiled <- firstShow (compileProfile (singleCardinalityProfile False Scalar [])) + optionalConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", textList)] "# Optional\n" + assertEqual + (mismatch Scalar textList) + (validateProfile PermissiveConformance optionalCompiled [optionalConcept]) + +testCardinalityVocabularyInteraction :: Either Text () +testCardinalityVocabularyInteraction = do + cid <- parseTestConceptId "cardinality" + scalarCompiled <- firstShow (compileProfile (singleCardinalityProfile True Scalar ["draft"])) + let objectValue = object ["status" .= ("draft" :: Text)] + objectConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", objectValue)] "# Object\n" + assertEqual + [CardinalityMismatch cid (fieldPath "value") Scalar objectValue] + (validateProfile PermissiveConformance scalarCompiled [objectConcept]) + listCompiled <- firstShow (compileProfile (singleCardinalityProfile True List ["draft"])) + let mixedList = toJSON ([String "draft", Number 1] :: [Value]) + listConcept <- profileConcept "cardinality" [("type", String "Extension"), ("value", mixedList)] "# List\n" + assertEqual + [ValueNotInVocabulary cid (fieldPath "value") ["draft"] mixedList] + (validateProfile PermissiveConformance listCompiled [listConcept]) + +testCompiledFieldFormats :: Either Text () +testCompiledFieldFormats = do + let baseType = firstTypeRule typeAwareProfileSpec + profileWith profileFormat typeFormat = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, fieldRule "homepage" Nothing [] Any (Just profileFormat) Nothing Nothing Nothing], + recommended = [], + optional = [] + }, + types = + [ withTypeFrontmatter + FrontmatterRules + { required = [fieldRule "homepage" Nothing [] Any (Just typeFormat) Nothing Nothing Nothing], + recommended = [], + optional = [] + } + baseType + ] + } + refined <- firstShow (compileProfile (profileWith Uri (UriWithScheme "https"))) + valid <- profileConcept "format-refinement" [("type", String "Owned Concept"), ("homepage", String "HTTPS://example.test/path")] "# Valid\n" + invalid <- profileConcept "format-refinement" [("type", String "Owned Concept"), ("homepage", String "http://example.test/path")] "# Invalid\n" + cid <- parseTestConceptId "format-refinement" + assertEqual [] (validateProfile PermissiveConformance refined [valid]) + assertEqual + [ValueFormatMismatch cid (fieldPath "homepage") (UriWithScheme "https") (String "http://example.test/path")] + (validateProfile PermissiveConformance refined [invalid]) + assertEqual + (Left (ConflictingFieldFormat (fieldPath "homepage") Date Rfc3339Utc :| [])) + (compileProfile (profileWith Date Rfc3339Utc)) + +testInvalidFormatParameters :: Either Text () +testInvalidFormatParameters = do + let invalid = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = + [ fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, + fieldRule "handle" Nothing [] Any (Just (DocumentHandle "1ADR")) Nothing Nothing Nothing, + fieldRule "source" Nothing [] Any (Just (UriWithScheme "https_")) Nothing Nothing Nothing + ], + recommended = [], + optional = [] + }, + types = [] + } + assertEqual + ( Left + ( InvalidFormatParameter (fieldPath "handle") (DocumentHandle "1ADR") "1ADR" + :| [InvalidFormatParameter (fieldPath "source") (UriWithScheme "https_") "https_"] + ) + ) + (compileProfile invalid) + +testNamedFormatValidation :: Either Text () +testNamedFormatValidation = do + cid <- parseTestConceptId "format" + let check fieldFormat cardinality actual = do + compiled <- firstShow (compileProfile (singleFormatProfile cardinality fieldFormat)) + concept <- + profileConcept + "format" + ([("type", String "Extension")] <> maybe [] (\value -> [("value", value)]) actual) + "# Format\n" + pure (validateProfile PermissiveConformance compiled [concept]) + mismatch fieldFormat actual = [ValueFormatMismatch cid (fieldPath "value") fieldFormat actual] + for_ ["2024-02-29T23:59:59Z", "2026-07-29T17:00:00.125Z"] $ \value -> + check Rfc3339Utc Any (Just (String value)) >>= assertEqual [] + for_ ["2026-13-45T99:99:99Z", "2026-07-29T17:00:00+01:00", "2026-07-29 17:00:00Z"] $ \value -> + check Rfc3339Utc Any (Just (String value)) >>= assertEqual (mismatch Rfc3339Utc (String value)) + check Date Any (Just (String "2024-02-29")) >>= assertEqual [] + for_ ["2023-02-29", "2026-13-01", "2026-07-29T00:00:00Z"] $ \value -> + check Date Any (Just (String value)) >>= assertEqual (mismatch Date (String value)) + for_ ["https://example.test/path", "urn:example:item"] $ \value -> + check Uri Any (Just (String value)) >>= assertEqual [] + for_ ["relative/path", "https://example.test/bad%ZZ"] $ \value -> + check Uri Any (Just (String value)) >>= assertEqual (mismatch Uri (String value)) + check (UriWithScheme "mori") Any (Just (String "MORI://haskell/time")) >>= assertEqual [] + check (UriWithScheme "mori") Any (Just (String "https://example.test")) + >>= assertEqual (mismatch (UriWithScheme "mori") (String "https://example.test")) + check (DocumentHandle "ADR") Any (Just (String "ADR-7")) >>= assertEqual [] + for_ ["ADR-007", "IR-7"] $ \value -> + check (DocumentHandle "ADR") Any (Just (String value)) + >>= assertEqual (mismatch (DocumentHandle "ADR") (String value)) + let validUris = toJSON (["https://example.test", "urn:example:item"] :: [Text]) + mixedUris = toJSON ([String "https://example.test", Number 1] :: [Value]) + check Uri List (Just validUris) >>= assertEqual [] + check Uri List (Just mixedUris) >>= assertEqual (mismatch Uri mixedUris) + check Uri Scalar (Just validUris) + >>= assertEqual [CardinalityMismatch cid (fieldPath "value") Scalar validUris] + check Uri Any (Just (Number 1)) >>= assertEqual (mismatch Uri (Number 1)) + check Uri Any Nothing >>= assertEqual [] + +-- | The OKF v0.2 actor formats. Specification §7 defines exactly three shapes +-- and 'parseActor' classifies them, so @actor@ accepts those three and reports +-- everything else — including the specification's own illustrative +-- @author: team:ga4-docs@ from §5.1, which §7's convention does not define. The +-- case-sensitivity and empty-component cases come from 'Okf.Actor'. +testActorFormatValidation :: Either Text () +testActorFormatValidation = do + cid <- parseTestConceptId "format" + let check fieldFormat value = do + compiled <- firstShow (compileProfile (singleFormatProfile Any fieldFormat)) + concept <- + profileConcept "format" [("type", String "Extension"), ("value", String value)] "# Format\n" + pure (validateProfile PermissiveConformance compiled [concept]) + mismatch fieldFormat value = [ValueFormatMismatch cid (fieldPath "value") fieldFormat (String value)] + for_ ["human:ahormati", "process:finance-nightly", "reference_agent/gemini-2.5-pro"] $ \value -> + check Actor value >>= assertEqual [] + for_ ["nadeem", "team:ga4-docs", "Human:ahormati", "human:", "/version", "producer/"] $ \value -> + check Actor value >>= assertEqual (mismatch Actor value) + check Profile.HumanActor "human:ahormati" >>= assertEqual [] + for_ ["process:finance-nightly", "reference_agent/gemini-2.5-pro", "nadeem"] $ \value -> + check Profile.HumanActor value >>= assertEqual (mismatch Profile.HumanActor value) + +-- | The non-textual formats. A numeric /string/ is reported rather than +-- coerced, which is the point of being able to declare the format at all. +testNonTextualFormatValidation :: Either Text () +testNonTextualFormatValidation = do + cid <- parseTestConceptId "format" + let checkWith cardinality fieldFormat actual = do + compiled <- firstShow (compileProfile (singleFormatProfile cardinality fieldFormat)) + concept <- + profileConcept "format" [("type", String "Extension"), ("value", actual)] "# Format\n" + pure (validateProfile PermissiveConformance compiled [concept]) + check = checkWith Any + mismatch fieldFormat actual = [ValueFormatMismatch cid (fieldPath "value") fieldFormat actual] + for_ [Number 5000, Number 0, Number (-3)] $ \actual -> + check Integer actual >>= assertEqual [] + for_ [Number 5000, Number 0] $ \actual -> + check NonNegativeInteger actual >>= assertEqual [] + check NonNegativeInteger (Number (-3)) >>= assertEqual (mismatch NonNegativeInteger (Number (-3))) + for_ [Integer, NonNegativeInteger] $ \fieldFormat -> + for_ [String "5000", Number 5.5, Bool True] $ \actual -> + check fieldFormat actual >>= assertEqual (mismatch fieldFormat actual) + for_ [Bool True, Bool False] $ \actual -> + check Boolean actual >>= assertEqual [] + for_ [String "true", Number 1] $ \actual -> + check Boolean actual >>= assertEqual (mismatch Boolean actual) + -- A list is a list of values, so a format constrains each element. The + -- cardinality has to be declared, because a numeric format alone refines an + -- unspecified one to scalar. + let integers = toJSON ([1, 2, 3] :: [Int]) + mixed = toJSON ([Number 1, String "2"] :: [Value]) + checkWith List Integer integers >>= assertEqual [] + checkWith List Integer mixed >>= assertEqual (mismatch Integer mixed) + +-- | Declaring a non-textual format and no cardinality refines the rule to +-- 'Scalar'. Without the refinement the 'Any' cardinality routes presence through +-- the legacy predicate, which counts only non-empty text and non-empty arrays, +-- so a present @usage_count: 5000@ is reported /missing/ before its value is +-- ever examined. An explicitly declared cardinality still wins. +testNonTextualFormatRefinesCardinality :: Either Text () +testNonTextualFormatRefinesCardinality = do + cid <- parseTestConceptId "counted" + let specWith cardinality fieldFormat = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = + [ fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, + fieldRule "usage_count" Nothing [] cardinality (Just fieldFormat) Nothing Nothing Nothing + ], + recommended = [], + optional = [] + }, + allowUnknownTypes = True, + types = [] + } + check cardinality fieldFormat actual = do + compiled <- firstShow (compileProfile (specWith cardinality fieldFormat)) + concept <- + profileConcept "counted" [("type", String "Extension"), ("usage_count", actual)] "# Counted\n" + pure (validateProfile PermissiveConformance compiled [concept]) + for_ [NonNegativeInteger, Integer] $ \fieldFormat -> + check Any fieldFormat (Number 5000) >>= assertEqual [] + check Any Boolean (Bool False) >>= assertEqual [] + -- The gap this closes: a textual format leaves the rule at 'Any', where a + -- number still does not count as present. The value check runs regardless of + -- the presence verdict, so both violations are reported. + check Any Rfc3339Utc (Number 5000) + >>= assertEqual + [ MissingProfileField cid "usage_count" Nothing, + ValueFormatMismatch cid (fieldPath "usage_count") Rfc3339Utc (Number 5000) + ] + -- An explicit cardinality wins, and a list of integers stays coherent rather + -- than becoming an error. + let integers = toJSON ([1, 2] :: [Int]) + check List NonNegativeInteger integers >>= assertEqual [] + check Scalar NonNegativeInteger integers + >>= assertEqual [CardinalityMismatch cid (fieldPath "usage_count") Scalar integers] + +-- | The two new narrowing pairs, checked the way the 'Uri'/'UriWithScheme' pair +-- is: a profile-scope format and a narrower type-scope one compile to the +-- narrower rule rather than to a 'ConflictingFieldFormat'. +testNewFormatsNarrowAcrossScopes :: Either Text () +testNewFormatsNarrowAcrossScopes = do + cid <- parseTestConceptId "narrowing" + let baseType = firstTypeRule typeAwareProfileSpec + profileWith profileFormat typeFormat = + typeAwareProfileSpec + { -- v0.2, for the same reason 'singleFormatProfile' is: the narrowing + -- pairs under test include the actor formats. + okfVersion = "0.2", + frontmatter = + FrontmatterRules + { required = + [ fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing, + fieldRule "value" Nothing [] Any (Just profileFormat) Nothing Nothing Nothing + ], + recommended = [], + optional = [] + }, + types = + [ withTypeFrontmatter + FrontmatterRules + { required = [fieldRule "value" Nothing [] Any (Just typeFormat) Nothing Nothing Nothing], + recommended = [], + optional = [] + } + baseType + ] + } + check profileFormat typeFormat actual = do + compiled <- firstShow (compileProfile (profileWith profileFormat typeFormat)) + concept <- + profileConcept "narrowing" [("type", String "Owned Concept"), ("value", actual)] "# Narrowing\n" + pure (validateProfile PermissiveConformance compiled [concept]) + for_ [(Actor, Profile.HumanActor), (Profile.HumanActor, Actor)] $ \(wide, narrow) -> do + check wide narrow (String "human:ahormati") >>= assertEqual [] + check wide narrow (String "process:nightly") + >>= assertEqual + [ValueFormatMismatch cid (fieldPath "value") Profile.HumanActor (String "process:nightly")] + for_ [(Integer, NonNegativeInteger), (NonNegativeInteger, Integer)] $ \(wide, narrow) -> do + check wide narrow (Number 5000) >>= assertEqual [] + check wide narrow (Number (-3)) + >>= assertEqual + [ValueFormatMismatch cid (fieldPath "value") NonNegativeInteger (Number (-3))] + assertEqual + (Left (ConflictingFieldFormat (fieldPath "value") Actor Integer :| [])) + (compileProfile (profileWith Actor Integer)) + +-- | Declares @okfVersion = "0.2"@ rather than inheriting 'typeAwareProfileSpec'\'s +-- @"0.1"@, because the formats under test include the OKF v0.2 actor +-- convention, and 'compileProfile' rejects a v0.2 format under a v0.1 +-- declaration. +singleFormatProfile :: Cardinality -> FieldFormat -> ProfileSpec +singleFormatProfile cardinality fieldFormat = + typeAwareProfileSpec + { okfVersion = "0.2", + frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], + recommended = [fieldRule "value" Nothing [] cardinality (Just fieldFormat) Nothing Nothing Nothing], + optional = [] + }, + allowUnknownTypes = True, + types = [] + } + +singleCardinalityProfile :: Bool -> Cardinality -> [Text] -> ProfileSpec +singleCardinalityProfile isRequired cardinality allowed = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing] <> [rule | isRequired], + recommended = [rule | not isRequired], + optional = [] + }, + allowUnknownTypes = True, + types = [] + } + where + rule = fieldRule "value" Nothing allowed cardinality Nothing Nothing Nothing Nothing + +testCompiledNestedRules :: Either Text () +testCompiledNestedRules = do + let profileRules = + NestedRules + { required = [NestedFieldRule "kind" Nothing ["decision", "implementation"] Any Nothing Nothing Nothing], + recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing Nothing], + optional = [] + } + typeRules = + NestedRules + { required = + [ NestedFieldRule "kind" Nothing ["implementation", "operations"] Any Nothing Nothing Nothing, + NestedFieldRule "outcome" Nothing ["approved", "rejected"] Any Nothing Nothing Nothing + ], + recommended = [], + optional = [] + } + base = nestedProfileWithRules Any profileRules (Just typeRules) + compiled <- firstShow (compileProfile base) + concept <- + profileConcept + "reviewed/merge" + [ ("type", String "Reviewed Concept"), + ( "reviews", + toJSON + [ object + [ "kind" .= ("decision" :: Text), + "outcome" .= ("approved" :: Text) + ] + ] + ) + ] + "# Merge\n" + cid <- parseTestConceptId "reviewed/merge" + assertEqual + [ ValueNotInVocabulary + cid + (nestedTestPath 0 "kind") + ["implementation"] + (String "decision") + ] + (validateProfile PermissiveConformance compiled [concept]) + let impossible = nestedProfileWithRules Scalar profileRules Nothing + assertEqual + (Left (ElementFieldsRequireList Nothing (fieldPath "reviews") Scalar :| [])) + (compileProfile impossible) + +testNestedRecordValidation :: Either Text () +testNestedRecordValidation = do + compiled <- firstShow (compileProfile nestedReviewProfileSpec) + let firstReview = + object + [ "kind" .= ("human" :: Text), + "reviewer" .= ("Ari" :: Text), + "reviewed_at" .= ("2026-07-29T16:00:00Z" :: Text), + "document_timestamp" .= ("2026-07-29T17:00:00Z" :: Text), + "scope" .= ("content" :: Text), + "outcome" .= ("approved" :: Text), + "context" .= ("Complete" :: Text), + "notes" .= ("No blockers" :: Text), + "provider" .= ("allowed-extra-key" :: Text) + ] + thirdReview = + object + [ "kind" .= ("model" :: Text), + "reviewer" .= ("Bo" :: Text), + "reviewed_at" .= ("2026-13-45T99:99:99Z" :: Text), + "document_timestamp" .= ("2026-07-29T17:00:00Z" :: Text), + "scope" .= ("invalid" :: Text), + "context" .= (["wrong"] :: [Text]) + ] + reviewValues = toJSON [firstReview, String "not-a-record", thirdReview] + concept <- + profileConcept + "reviewed/bad" + [("type", String "Reviewed Concept"), ("reviews", reviewValues)] + "# Bad\n" + cid <- parseTestConceptId "reviewed/bad" + let permissiveExpected = + [ NestedElementNotRecord cid (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), + CardinalityMismatch cid (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), + MissingNestedProfileField cid (nestedTestPath 2 "outcome") Nothing, + ValueFormatMismatch cid (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), + ValueNotInVocabulary cid (nestedTestPath 2 "scope") reviewScopes (String "invalid") + ] + assertEqual permissiveExpected (validateProfile PermissiveConformance compiled [concept]) + assertEqual + [ NestedElementNotRecord cid (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), + CardinalityMismatch cid (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), + MissingRecommendedNestedProfileField cid (nestedTestPath 2 "notes") Nothing, + MissingNestedProfileField cid (nestedTestPath 2 "outcome") Nothing, + ValueFormatMismatch cid (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), + ValueNotInVocabulary cid (nestedTestPath 2 "scope") reviewScopes (String "invalid") + ] + (validateProfile StrictAuthoring compiled [concept]) + +nestedProfileWithRules :: Cardinality -> NestedRules -> Maybe NestedRules -> ProfileSpec +nestedProfileWithRules outerCardinality profileNested typeNested = + ProfileSpec + { name = "nested-merge", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = + [ requiredField "type", + fieldRule "reviews" Nothing [] outerCardinality Nothing (Just profileNested) Nothing Nothing + ], + recommended = [], + optional = [] + }, + allowUnknownTypes = False, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = + [ TypeRule + { type_ = "Reviewed Concept", + description = Nothing, + frontmatter = + FrontmatterRules + { required = maybe [] (\rules -> [fieldRule "reviews" Nothing [] Any Nothing (Just rules) Nothing Nothing]) typeNested, + recommended = [], + optional = [] + }, + pathPattern = Nothing, + resourceScheme = Nothing, + requireSchemaSection = False, + schemaColumns = [], + idPrefix = Nothing + } + ] + } + +nestedReviewProfileSpec :: ProfileSpec +nestedReviewProfileSpec = + nestedProfileWithRules Any nestedRules Nothing + where + nestedRules = + NestedRules + { required = + [ NestedFieldRule "kind" Nothing ["human", "model"] Any Nothing Nothing Nothing, + NestedFieldRule "reviewer" Nothing [] Scalar Nothing Nothing Nothing, + NestedFieldRule "reviewed_at" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing, + NestedFieldRule "document_timestamp" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing, + NestedFieldRule "scope" Nothing reviewScopes Any Nothing Nothing Nothing, + NestedFieldRule "outcome" Nothing ["approved", "changes-requested", "commented"] Any Nothing Nothing Nothing, + NestedFieldRule "context" Nothing [] Scalar Nothing Nothing Nothing + ], + recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing Nothing], + optional = [] + } + +nestedTestPath :: Int -> Text -> FieldPath +nestedTestPath elementIndex key = + FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) + +-- | A profile whose single object-valued key carries the given member rules and +-- the given declared cardinality. Built with record syntax rather than the +-- positional 'fieldRule' helper precisely because @objectFields@ is the member +-- under test here. +objectProfileWithRules :: Text -> Cardinality -> Maybe NestedRules -> Maybe NestedRules -> ProfileSpec +objectProfileWithRules key declaredCardinality objectRules elementRules = + ProfileSpec + { name = "object-rules", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = + [ requiredField "type", + FieldRule + { field = key, + description = Nothing, + allowedValues = [], + cardinality = declaredCardinality, + format = Nothing, + elementFields = elementRules, + objectFields = objectRules, + reference = Nothing, + path = Nothing, + when = Nothing + } + ], + recommended = [], + optional = [] + }, + allowUnknownTypes = True, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = [] + } + +-- | The member rules used by the object-rule tests: @by@ is demanded, @at@ is +-- recommended and must be an RFC3339 UTC timestamp. +provenanceMemberRules :: NestedRules +provenanceMemberRules = + NestedRules + { required = [NestedFieldRule "by" (Just "Who or what produced this content.") [] Any Nothing Nothing Nothing], + recommended = [NestedFieldRule "at" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing], + optional = [] + } + +-- | Declaring @objectFields@ next to an explicit scalar or list cardinality is +-- incoherent — a mapping is neither — and is rejected at compile time in both +-- directions, mirroring 'ElementFieldsRequireList' for the opposite mistake. +testObjectFieldsRequireObjectShape :: Either Text () +testObjectFieldsRequireObjectShape = do + assertEqual + (Left (ObjectFieldsRequireObjectShape Nothing (fieldPath "generated") List :| [])) + (compileProfile (objectProfileWithRules "generated" List (Just provenanceMemberRules) Nothing)) + assertEqual + (Left (ObjectFieldsRequireObjectShape Nothing (fieldPath "generated") Scalar :| [])) + (compileProfile (objectProfileWithRules "generated" Scalar (Just provenanceMemberRules) Nothing)) + +-- | A rule that declares object members and no explicit cardinality is refined +-- to 'Object', the compiled-only cardinality that has no Dhall spelling, and its +-- members are reachable through the new accessor. +testCompileObjectRule :: Either Text () +testCompileObjectRule = do + compiled <- + firstShow + (compileProfile (objectProfileWithRules "generated" Any (Just provenanceMemberRules) Nothing)) + rule <- lookupBaseRule compiled "generated" + assertEqual Object (fieldRuleCardinality rule) + assertEqual Nothing (fieldRuleElementFields rule) + case fieldRuleObjectFields rule of + Nothing -> Left "expected compiled object member rules" + Just members -> do + assertEqual ["at", "by"] (Map.keys members) + byRule <- maybe (Left "expected a rule for by") Right (Map.lookup "by" members) + assertEqual + (Just "Who or what produced this content.") + (fieldRuleDescription byRule) + assertEqual [RequiredField] (map presenceClauseRequirement (fieldRulePresenceClauses byRule)) + -- Depth-bounded: a member rule never itself carries a nested shape. + assertEqual Nothing (fieldRuleObjectFields byRule) + assertEqual Nothing (fieldRuleElementFields byRule) + +-- | A rule declaring both shapes stays at 'Any' cardinality, which is what lets +-- either OKF v0.2 spelling of @verified@ satisfy it, and compiles the same +-- member rules under both accessors. +testCompileRecordOrListRule :: Either Text () +testCompileRecordOrListRule = do + compiled <- + firstShow + ( compileProfile + (objectProfileWithRules "verified" Any (Just provenanceMemberRules) (Just provenanceMemberRules)) + ) + rule <- lookupBaseRule compiled "verified" + assertEqual Any (fieldRuleCardinality rule) + assertEqual (Just ["at", "by"]) (Map.keys <$> fieldRuleObjectFields rule) + assertEqual (Just ["at", "by"]) (Map.keys <$> fieldRuleElementFields rule) + +-- | A profile with one path rule on a top-level key, plus the given rules on the +-- same key at type scope, so scheme intersection across scopes is exercisable. +pathProfileWith :: Maybe PathReferenceRule -> Maybe FieldFormat -> Maybe HandleReferenceRule -> Maybe PathReferenceRule -> ProfileSpec +pathProfileWith profilePath declaredFormat handlePolicy typePath = + ProfileSpec + { name = "path-rules", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [requiredField "type"], + recommended = [], + -- Optional rather than required, so a concept that simply does not + -- carry the key reports nothing and the tests below see only the + -- value checks they are about. An optional rule is fully + -- value-checked whenever it is present. + optional = + [ (requiredField "resource") + { format = declaredFormat, + reference = handlePolicy, + path = profilePath + } + ] + }, + allowUnknownTypes = True, + allowUnknownFields = True, + idField = if isJust handlePolicy then Just "docId" else Nothing, + requireBundleVersion = Nothing, + types = + [ TypeRule + { type_ = "Metric", + description = Nothing, + frontmatter = + FrontmatterRules + { required = [], + recommended = [], + optional = [(requiredField "resource") {path = typePath}] + }, + pathPattern = Nothing, + resourceScheme = Nothing, + requireSchemaSection = False, + schemaColumns = [], + idPrefix = if isJust handlePolicy then Just "ADR" else Nothing + } + | isJust typePath || isJust handlePolicy + ] + } + +-- | A profile whose @sources@ key is a list of records, each of which carries a +-- path rule on @resource@ — the OKF v0.2 §6.2 field the rule kind exists for, +-- and the one that was unreachable before nested path checking existed. +sourcesPathProfile :: [Text] -> ProfileSpec +sourcesPathProfile permittedSchemes = + ProfileSpec + { name = "sources-paths", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [requiredField "type"], + recommended = [], + -- Optional for the same reason 'pathProfileWith' is: the tests are + -- about what a present value resolves to, not about presence. + optional = [fieldRule "sources" Nothing [] List Nothing (Just memberRules) Nothing Nothing] + }, + allowUnknownTypes = True, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = [] + } + where + memberRules = + NestedRules + { required = + [ (NestedFieldRule "resource" Nothing [] Any Nothing Nothing Nothing) + { path = Just (PathReferenceRule permittedSchemes False) + } + ], + recommended = [], + optional = [] + } + +-- | Compiling a path rule normalizes its scheme list exactly as a handle rule's +-- is — deduplicated case-insensitively and case-folded for storage — and the +-- result is reachable through the new accessor at top-level, nested, and object +-- scope. Nested reachability is the part with no precedent: +-- 'compileOptionalNestedFieldRule' previously hard-coded every reference member +-- to 'Nothing'. +testCompilePathRule :: Either Text () +testCompilePathRule = do + compiled <- + firstShow + (compileProfile (pathProfileWith (Just (PathReferenceRule ["HTTPS", "https", "mori"] True)) Nothing Nothing Nothing)) + rule <- lookupBaseRule compiled "resource" + assertEqual (Just (PathReferenceRule ["https", "mori"] True)) (fieldRulePath rule) + -- A path rule and a handle rule are different things and never both present. + assertEqual Nothing (fieldRuleReference rule) + nestedCompiled <- firstShow (compileProfile (sourcesPathProfile ["https"])) + sourcesRule <- lookupBaseRule nestedCompiled "sources" + case fieldRuleElementFields sourcesRule of + Nothing -> Left "expected compiled element member rules for sources" + Just members -> do + memberRule <- maybe (Left "expected a rule for resource") Right (Map.lookup "resource" members) + assertEqual (Just (PathReferenceRule ["https"] False)) (fieldRulePath memberRule) + -- Nested rules stay depth-bounded and carry no handle policy at all. + assertEqual Nothing (fieldRuleReference memberRule) + +-- | A type-scope path rule narrows the profile-scope one rather than replacing +-- it: schemes intersect and @allowSelf@ combines with logical AND. Unlike +-- 'mergeReferenceRule' the merge is total, because a path policy has no +-- @localPrefix@ for two scopes to disagree about. +testMergePathRule :: Either Text () +testMergePathRule = do + compiled <- + firstShow + ( compileProfile + ( pathProfileWith + (Just (PathReferenceRule ["https", "mori"] True)) + Nothing + Nothing + (Just (PathReferenceRule ["mori", "ftp"] False)) + ) + ) + merged <- lookupCompiledRule "resource" (compiledProfileRulesForType compiled "Metric") + assertEqual (Just (PathReferenceRule ["mori"] False)) (fieldRulePath merged) + +-- | The three ways a path rule can be incoherent on its own. Two reuse the +-- handle-reference definition errors because the claim is identical; the third +-- is new, and cannot arise at nested scope where 'NestedFieldRule' carries no +-- handle policy. +testPathDefinitionErrors :: Either Text () +testPathDefinitionErrors = do + -- A value cannot be resolved as both a PREFIX-N handle and a §6.2 path. + assertEqual + (Left (PathReferenceWithHandleReference Nothing (fieldPath "resource") :| [])) + ( compileProfile + ( pathProfileWith + (Just (PathReferenceRule [] False)) + Nothing + (Just (HandleReferenceRule "ADR" [] False)) + Nothing + ) + ) + -- A scheme that is not a legal URI scheme, at top-level scope. + assertEqual + (Left (InvalidExternalReferenceScheme Nothing (fieldPath "resource") "9nope" :| [])) + (compileProfile (pathProfileWith (Just (PathReferenceRule ["9nope"] False)) Nothing Nothing Nothing)) + -- The same mistake at nested scope, which the reference walk did not reach + -- before this plan extended it. + assertEqual + (Left (InvalidExternalReferenceScheme Nothing (objectMemberPath "sources" "resource") "9nope" :| [])) + (compileProfile (sourcesPathProfile ["9nope"])) + -- A named format would be checked against text the path rule is already + -- interpreting structurally, and the two can contradict. + assertEqual + (Left (ReferenceWithFormat Nothing (fieldPath "resource") Uri :| [])) + (compileProfile (pathProfileWith (Just (PathReferenceRule [] False)) (Just Uri) Nothing Nothing)) + +-- | The five outcomes of checking one path value at top-level scope, plus the +-- two shapes that are accepted in silence. Every diagnostic carries the raw text +-- the author wrote rather than the collapsed path okf computed from it. +testValidatePathTopLevel :: Either Text () +testValidatePathTopLevel = do + compiled <- + firstShow + (compileProfile (pathProfileWith (Just (PathReferenceRule ["https"] False)) Nothing Nothing Nothing)) + cid <- parseTestConceptId "metrics/revenue" + target <- profileConcept "references/policy" [("type", String "Reference")] "# Policy\n" + let check value = do + subject <- + profileConcept + "metrics/revenue" + [("type", String "Metric"), ("resource", value)] + "# Revenue\n" + pure (validateProfile PermissiveConformance compiled [subject, target]) + resourcePath = fieldPath "resource" + -- A bundle path naming a real concept, and a permitted external URL, are both + -- silent. + check (String "/references/policy.md") >>= assertEqual [] + check (String "../references/policy.md") >>= assertEqual [] + check (String "https://wiki.acme/revenue") >>= assertEqual [] + -- A path to a non-Markdown file is accepted without a check, because + -- validateProfile is handed concepts and never looked. §6.3's own example. + check (String "/references/attesters/revenue.py") >>= assertEqual [] + -- The four failures. + check (String "/references/gone.md") + >>= assertEqual [DanglingPathReference cid resourcePath "/references/gone.md"] + check (String "ftp://files.acme/revenue.csv") + >>= assertEqual [ExternalReferenceSchemeNotAllowed cid resourcePath "ftp" ["https"]] + check (String "../../../etc/passwd") + >>= assertEqual [PathEscapesBundle cid resourcePath "../../../etc/passwd"] + check (String " ") + >>= assertEqual [MalformedPathReference cid resourcePath (String " ")] + -- A value that is not text at all is malformed rather than silently skipped. + check (Bool True) + >>= assertEqual [MalformedPathReference cid resourcePath (Bool True)] + -- A path resolving to the concept that carries it, with allowSelf unset. + check (String "/metrics/revenue.md") + >>= assertEqual [SelfDocumentReference cid resourcePath "/metrics/revenue.md"] + +-- | The core-versus-profile divergence, closed: 'validateProfileWith' resolves a +-- path naming a file that is not a concept, and 'validateProfile' still cannot +-- and still says nothing. +-- +-- Run against a real directory because that is the only way to have an inventory +-- holding a file 'walkBundle' filters out. @dangling-frontmatter-path@ carries +-- both halves already: @non-markdown.md@ names a @.py@ that is there and +-- @dangling.md@ names a @.txt@ that is not. +-- +-- Specification §6.3's example is exactly this shape, and +-- @docs\/adr\/13-the-references-convention-and-non-markdown-files.md@ records why +-- the silent answer is preserved rather than tightened: a caller with no +-- directory has not looked, and reporting a target it never checked would be a +-- claim okf cannot back. +testValidateProfileWithInventory :: IO (Either Text ()) +testValidateProfileWithInventory = do + root <- fixturePath "dangling-frontmatter-path" + concepts <- readBundle root + inventory <- readBundleInventory root + pure + ( do + compiled <- + firstShow + ( compileProfile + (pathProfileWith (Just (PathReferenceRule ["bigquery"] False)) Nothing Nothing Nothing) + ) + danglingId <- firstShow (parseConceptId "dangling") + specSpellingId <- firstShow (parseConceptId "computations/spec-spelling") + let resourcePath = fieldPath "resource" + -- With the full inventory: the missing .txt and the relative .py that + -- resolves outside the bundle are both reported, and the .py that is + -- really there is silent. + assertEqual + [ DanglingPathReference specSpellingId resourcePath "references/attesters/revenue.py", + DanglingPathReference danglingId resourcePath "/references/deleted.txt" + ] + (validateProfileWith inventory PermissiveConformance compiled concepts) + -- Without it: nothing at all, exactly as before this plan. Neither target + -- is Markdown, so a concepts-only caller has not looked at either. + assertEqual [] (validateProfile PermissiveConformance compiled concepts) + ) + +-- | The specification §10 contract expressed as a house convention, run against +-- the bundle it was written for. +-- +-- This is the descriptor @docs\/user\/profiles.md@ shows, and this test is what +-- stops that document's transcript from rotting: the descriptor must keep +-- compiling ('testFrozenFixturesCompile' lists it) and must keep reporting these +-- deviations and no others. +-- +-- What it demonstrates is the boundary this whole initiative rests on. okf's core +-- enforces exactly §10.2's one REQUIRED field and §10.3's exactly-one rule; +-- everything below — that a parameter carry a @type@, that an executor be +-- declared at all — is a team's own policy, reached with @objectFields@ for the +-- mapping-valued keys and @elementFields@ for the list-valued one, and scoped to +-- one @type@ with a 'TypeRule' so no @Metric@ in the bundle is asked for a +-- @runtime@. +-- +-- @computations\/churn@ is the concept that makes the point: it produces no core +-- diagnostic at all and one deviation here. +testAttestedComputationHouseProfile :: IO (Either Text ()) +testAttestedComputationHouseProfile = do + descriptorPath <- fixtureFilePath "profiles/attested-computation-house.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "attested-computation" + concepts <- readBundle root + inventory <- readBundleInventory root + pure $ case loaded of + Left err -> Left ("failed to load the house attested computation profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + bothId <- firstShow (parseConceptId "computations/both-computations") + churnId <- firstShow (parseConceptId "computations/churn") + marginId <- firstShow (parseConceptId "computations/margin") + noneId <- firstShow (parseConceptId "computations/no-computation") + twoBlocksId <- firstShow (parseConceptId "computations/two-blocks") + -- Only the required rules fire in permissive mode. `computations/revenue` + -- carries the whole contract and is absent from both lists. + assertEqual + [ MissingProfileField bothId "executor" Nothing, + MissingProfileField bothId "parameters" Nothing, + MissingNestedProfileField churnId parameterTypePath Nothing, + MissingProfileField marginId "executor" Nothing, + MissingProfileField noneId "executor" Nothing, + MissingProfileField noneId "parameters" Nothing, + MissingProfileField twoBlocksId "executor" Nothing, + MissingProfileField twoBlocksId "parameters" Nothing + ] + (validateProfileWith inventory PermissiveConformance compiled concepts) + -- Under strict the recommended rules join them, including the nested + -- `executor.receipt` on the one concept that declares an executor without + -- one. No path deviation appears in either list: every path-valued field in + -- this bundle resolves. + assertEqual + [ MissingRecommendedProfileField bothId "attester" Nothing, + MissingProfileField bothId "executor" Nothing, + MissingProfileField bothId "parameters" Nothing, + MissingRecommendedProfileField churnId "attester" Nothing, + MissingRecommendedNestedProfileField churnId executorReceiptPath Nothing, + MissingNestedProfileField churnId parameterTypePath Nothing, + MissingRecommendedProfileField marginId "attester" Nothing, + MissingProfileField marginId "executor" Nothing, + MissingRecommendedProfileField noneId "attester" Nothing, + MissingProfileField noneId "executor" Nothing, + MissingProfileField noneId "parameters" Nothing, + MissingRecommendedProfileField twoBlocksId "attester" Nothing, + MissingProfileField twoBlocksId "executor" Nothing, + MissingProfileField twoBlocksId "parameters" Nothing + ] + (validateProfileWith inventory StrictAuthoring compiled concepts) + where + parameterTypePath = FieldPath (FieldName "parameters" :| [ArrayIndex 0, FieldName "type"]) + executorReceiptPath = FieldPath (FieldName "executor" :| [FieldName "receipt"]) + +-- | The motivating case: a path rule on @sources[].resource@, reported with the +-- element index so the author can find the entry. Nested path checking did not +-- exist before this plan — 'NestedFieldRule' had no reference member of any kind +-- — so this is the assertion the whole plan is for. +testValidatePathNested :: Either Text () +testValidatePathNested = do + compiled <- firstShow (compileProfile (sourcesPathProfile ["https"])) + cid <- parseTestConceptId "metric" + target <- profileConcept "references/policy" [("type", String "Reference")] "# Policy\n" + subject <- + profileConcept + "metric" + [ ("type", String "Metric"), + ( "sources", + toJSON + [ object ["id" .= ("policy" :: Text), "resource" .= ("/references/policy.md" :: Text)], + object ["id" .= ("gone" :: Text), "resource" .= ("/references/gone.md" :: Text)], + object ["id" .= ("upstream" :: Text), "resource" .= ("https://wiki.acme/revenue" :: Text)], + object ["id" .= ("ftp" :: Text), "resource" .= ("ftp://files.acme/revenue.csv" :: Text)], + object ["id" .= ("escape" :: Text), "resource" .= ("../../etc/passwd" :: Text)], + object ["id" .= ("script" :: Text), "resource" .= ("references/attesters/revenue.py" :: Text)] + ] + ) + ] + "# Revenue\n" + assertEqual + [ DanglingPathReference cid (nestedTestPathIn "sources" 1 "resource") "/references/gone.md", + ExternalReferenceSchemeNotAllowed cid (nestedTestPathIn "sources" 3 "resource") "ftp" ["https"], + PathEscapesBundle cid (nestedTestPathIn "sources" 4 "resource") "../../etc/passwd" + ] + (validateProfile PermissiveConformance compiled [subject, target]) + +-- | The same rule kind at object scope, where the member is named without an +-- index: @executor.resource@ rather than @executor[0].resource@. +testValidatePathObjectScope :: Either Text () +testValidatePathObjectScope = do + compiled <- + firstShow + ( compileProfile + ( objectProfileWithRules + "executor" + Any + ( Just + NestedRules + { required = + [ (NestedFieldRule "resource" Nothing [] Any Nothing Nothing Nothing) + { path = Just (PathReferenceRule [] False) + } + ], + recommended = [], + optional = [] + } + ) + Nothing + ) + ) + cid <- parseTestConceptId "thing" + subject <- + profileConcept + "thing" + [("type", String "Thing"), ("executor", object ["resource" .= ("/computations/gone.md" :: Text)])] + "# Thing\n" + assertEqual + [DanglingPathReference cid (objectMemberPath "executor" "resource") "/computations/gone.md"] + (validateProfile PermissiveConformance compiled [subject]) + +nestedTestPathIn :: Text -> Int -> Text -> FieldPath +nestedTestPathIn parent elementIndex key = + FieldPath (FieldName parent :| [ArrayIndex elementIndex, FieldName key]) + +-- | A profile declaring the given @okfVersion@, with the given rules in the +-- given presence list, so the version checks can be exercised in one shape. +versionProfileWith :: Text -> Text -> [FieldRule] -> ProfileSpec +versionProfileWith declaredVersion listName rules = + ProfileSpec + { name = "versioned", + description = Nothing, + okfVersion = declaredVersion, + frontmatter = + FrontmatterRules + { required = [requiredField "type"] <> [rule | rule <- rules, listName == "required"], + recommended = [rule | rule <- rules, listName == "recommended"], + optional = [rule | rule <- rules, listName == "optional"] + }, + allowUnknownTypes = True, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = [] + } + +-- | An @okfVersion@ okf cannot read at all, and one naming a major version okf +-- does not implement. The second deliberately diverges from the bundle-side rule +-- of specification §12: a bundle may come from a third party and is read +-- best-effort, while a profile is an instruction to okf whose author is present. +testProfileVersionParsing :: Either Text () +testProfileVersionParsing = do + assertEqual + (Left (InvalidProfileOkfVersion "banana" :| [])) + (compileProfile (versionProfileWith "banana" "optional" [])) + assertEqual + (Left (ProfileOkfVersionNotUnderstood "1.0" :| [])) + (compileProfile (versionProfileWith "1.0" "optional" [])) + +-- | A higher /minor/ within a known major is clamped rather than rejected, +-- mirroring 'Okf.Validation.versionGate': §12 defines a minor bump as +-- backward-compatible additions, so a v0.9 profile expresses only rules okf +-- already understands. The clamp is observable through the diagnostic, which +-- names the effective version rather than the declared one. +testProfileVersionMinorClamp :: Either Text () +testProfileVersionMinorClamp = do + let timestampRule = fieldRule "timestamp" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing Nothing + assertEqual + (Left (FieldSupersededInOkfVersion Nothing (fieldPath "timestamp") "0.2" "0.2" :| [])) + (compileProfile (versionProfileWith "0.9" "recommended" [timestampRule])) + -- And a v0.9 profile that names nothing version-specific simply compiles. + case compileProfile (versionProfileWith "0.9" "optional" []) of + Left errs -> Left ("expected a v0.9 profile to compile, got " <> Text.pack (show (toList errs))) + Right _ -> Right () + +-- | A profile that demands a bundle version okf cannot parse is rejected at +-- compile time, before any bundle is read: no declaration could ever be compared +-- against it, so the descriptor is asking for something unanswerable. +-- +-- An unknown /major/ is deliberately accepted here, unlike in @okfVersion@. There +-- the profile asks okf to interpret rules it may not understand; here it states a +-- minimum that a bundle's own declaration is compared against, which stays +-- meaningful whatever the major is. +testRequiredBundleVersionParsing :: Either Text () +testRequiredBundleVersionParsing = do + assertEqual + (Left (InvalidRequiredBundleVersion "banana" :| [])) + (compileProfile (requireBundleVersionProfile (Just "banana"))) + for_ [Just "0.2", Just "1.0", Nothing] $ \required -> + case compileProfile (requireBundleVersionProfile required) of + Left errs -> Left ("expected a clean compile, got " <> Text.pack (show (toList errs))) + Right _ -> Right () + +-- | What each shape of a bundle's §12 declaration means against a profile that +-- requires 0.2. A bundle ahead of the minimum is not a deviation; one behind it, +-- one that says nothing, and one okf cannot parse all are. +testValidateProfileVersion :: Either Text () +testValidateProfileVersion = do + compiled <- firstShow (compileProfile (requireBundleVersionProfile (Just "0.2"))) + assertEqual [] (validateProfileVersion (VersionDeclared (OkfVersion 0 2)) compiled) + assertEqual [] (validateProfileVersion (VersionDeclared (OkfVersion 0 3)) compiled) + assertEqual [] (validateProfileVersion (VersionDeclared (OkfVersion 1 0)) compiled) + assertEqual + [RequiredBundleVersionUnmet "0.2" (Just "0.1")] + (validateProfileVersion (VersionDeclared (OkfVersion 0 1)) compiled) + assertEqual + [RequiredBundleVersionUnmet "0.2" Nothing] + (validateProfileVersion VersionUndeclared compiled) + assertEqual + [RequiredBundleVersionUnmet "0.2" (Just "banana")] + (validateProfileVersion (VersionUnparseable "banana") compiled) + +-- | The default is inert: a profile that requires nothing reports nothing, +-- whatever the bundle declares. Almost every profile is this one. +testValidateProfileVersionUnrequired :: Either Text () +testValidateProfileVersionUnrequired = do + compiled <- firstShow (compileProfile (requireBundleVersionProfile Nothing)) + assertEqual Nothing (compiledProfileRequiredBundleVersion compiled) + for_ + [ VersionDeclared (OkfVersion 0 1), + VersionDeclared (OkfVersion 0 2), + VersionUnparseable "banana", + VersionUndeclared + ] + (\declaration -> assertEqual [] (validateProfileVersion declaration compiled)) + +-- | A minimal v0.2 profile whose only interesting member is the requirement under +-- test. +requireBundleVersionProfile :: Maybe Text -> ProfileSpec +requireBundleVersionProfile required = + (versionProfileWith "0.2" "optional" []) {requireBundleVersion = required} + +-- | A key the declared version supersedes is an error where it is /demanded/ and +-- legal where it is merely documented. The optional list is how a team migrating +-- a corpus says "tolerated but not demanded", and making it an error everywhere +-- would leave no way to describe a migration. +testProfileVersionSupersededField :: Either Text () +testProfileVersionSupersededField = do + let timestampRule = fieldRule "timestamp" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing Nothing + superseded = FieldSupersededInOkfVersion Nothing (fieldPath "timestamp") "0.2" "0.2" + assertEqual + (Left (superseded :| [])) + (compileProfile (versionProfileWith "0.2" "required" [timestampRule])) + assertEqual + (Left (superseded :| [])) + (compileProfile (versionProfileWith "0.2" "recommended" [timestampRule])) + -- The migration shape, and the v0.1 profile that has no reason to be told + -- anything at all. + for_ [versionProfileWith "0.2" "optional" [timestampRule], versionProfileWith "0.1" "required" [timestampRule]] $ \spec -> + case compileProfile spec of + Left errs -> Left ("expected a clean compile, got " <> Text.pack (show (toList errs))) + Right _ -> Right () + +-- | The actor formats encode the specification §7 convention v0.2 introduced, so +-- naming one under a v0.1 declaration is incoherent. A format is an okf +-- descriptor feature rather than a key name, which is exactly why this check is +-- safe where the mirror check on key names is not — see +-- 'testProfileVersionDoesNotJudgeKeyNames'. +testProfileVersionActorFormat :: Either Text () +testProfileVersionActorFormat = do + let actorRule = fieldRule "author" Nothing [] Any (Just Actor) Nothing Nothing Nothing + humanRule = fieldRule "author" Nothing [] Any (Just Profile.HumanActor) Nothing Nothing Nothing + assertEqual + (Left (FormatRequiresOkfVersion Nothing (fieldPath "author") Actor "0.1" "0.2" :| [])) + (compileProfile (versionProfileWith "0.1" "optional" [actorRule])) + assertEqual + (Left (FormatRequiresOkfVersion Nothing (fieldPath "author") Profile.HumanActor "0.1" "0.2" :| [])) + (compileProfile (versionProfileWith "0.1" "optional" [humanRule])) + -- The same rule under a v0.2 declaration is exactly what the format is for. + case compileProfile (versionProfileWith "0.2" "optional" [actorRule]) of + Left errs -> Left ("expected a v0.2 actor rule to compile, got " <> Text.pack (show (toList errs))) + Right _ -> Right () + +-- | The check okf deliberately does /not/ perform, asserted so it is not added +-- back by someone who thinks it was forgotten. +-- +-- A v0.1 profile constraining its own @status@, @sources@, or @verified@ key is +-- coherent: per @docs\/adr\/1-profile-declared-document-ids.md@ constraining keys +-- the core format does not own is what profiles are /for/, and these are ordinary +-- words teams were already using before v0.2 claimed them. Rejecting +-- @field.enum "status" ["proposed", "accepted"]@ for naming an ADR lifecycle +-- would be a false positive on a descriptor okf cannot see. +testProfileVersionDoesNotJudgeKeyNames :: Either Text () +testProfileVersionDoesNotJudgeKeyNames = + for_ ["status", "sources", "verified", "generated", "stale_after", "usage_window"] $ \key -> + let houseRule = fieldRule key Nothing ["proposed", "accepted"] Any Nothing Nothing Nothing Nothing + in case compileProfile (versionProfileWith "0.1" "optional" [houseRule]) of + Left errs -> + Left ("a v0.1 profile naming " <> key <> " should compile, got " <> Text.pack (show (toList errs))) + Right _ -> Right () + +lookupBaseRule :: CompiledProfile -> Text -> Either Text EffectiveFieldRule +lookupBaseRule compiled key = + maybe + (Left ("expected a compiled rule for " <> key)) + Right + (Map.lookup key (compiledProfileBaseRules compiled)) + +reviewScopes :: [Text] +reviewScopes = ["content", "technical-accuracy", "editorial", "catalog-metadata", "content-and-metadata"] + +testConditionDefinitionErrors :: Either Text () +testConditionDefinitionErrors = do + let source key values sourceCardinality = + fieldRule key Nothing values sourceCardinality Nothing Nothing Nothing Nothing + target key sourceKey values = + fieldRule key Nothing [] Any Nothing Nothing Nothing (Just (FieldCondition sourceKey values)) + compileWith rules = + compileProfile + typeAwareProfileSpec + { frontmatter = FrontmatterRules {required = rules, recommended = [], optional = []}, + allowUnknownTypes = True, + types = [] + } + targetPath key = fieldPath key + assertEqual + (Left (EmptyConditionValues Nothing (targetPath "target") (targetPath "status") :| [])) + (compileWith [source "status" ["active"] Scalar, target "target" "status" []]) + assertEqual + (Left (ConditionFieldNotDeclared Nothing (targetPath "target") (targetPath "missing") :| [])) + (compileWith [target "target" "missing" ["active"]]) + assertEqual + (Left (ConditionFieldNotScalar Nothing (targetPath "target") (targetPath "status") List :| [])) + (compileWith [source "status" ["active"] List, target "target" "status" ["active"]]) + assertEqual + (Left (ConditionFieldOpenVocabulary Nothing (targetPath "target") (targetPath "status") :| [])) + (compileWith [source "status" [] Scalar, target "target" "status" ["active"]]) + assertEqual + (Left (ConditionFieldHasUnreachableValues Nothing (targetPath "target") (targetPath "status") ["superseded"] ["active"] :| [])) + (compileWith [source "status" ["active"] Scalar, target "target" "status" ["superseded"]]) + assertEqual + (Left (SelfConditionalField Nothing (targetPath "status") :| [])) + (compileWith [fieldRule "status" Nothing ["active"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["active"]))]) + let nestedCrossScope = + NestedRules + { required = + [ NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing Nothing, + NestedFieldRule "provider" Nothing [] Scalar Nothing Nothing (Just (FieldCondition "status" ["active"])) + ], + recommended = [], + optional = [] + } + crossScopeProfile = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = + [ source "status" ["active"] Scalar, + fieldRule "reviews" Nothing [] List Nothing (Just nestedCrossScope) Nothing Nothing + ], + recommended = [], + optional = [] + }, + allowUnknownTypes = True, + types = [] + } + assertEqual + (Left (ConditionFieldNotDeclared Nothing (nestedDefinitionTestPath "reviews" "provider") (nestedDefinitionTestPath "reviews" "status") :| [])) + (compileProfile crossScopeProfile) + where + nestedDefinitionTestPath parent child = + FieldPath (FieldName parent :| [FieldName child]) + +testTopLevelConditionalPresence :: Either Text () +testTopLevelConditionalPresence = do + let statusRule = fieldRule "status" Nothing ["active", "superseded"] Scalar Nothing Nothing Nothing Nothing + recommendedTarget = + fieldRule "supersededBy" Nothing ["ADR-1"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["active"])) + requiredTarget = + fieldRule "supersededBy" Nothing ["ADR-1"] Scalar Nothing Nothing Nothing (Just (FieldCondition "status" ["superseded"])) + base = + typeAwareProfileSpec + { frontmatter = FrontmatterRules {required = [requiredField "type", statusRule], recommended = [recommendedTarget], optional = []}, + allowUnknownTypes = True, + types = + [ withTypeFrontmatter + FrontmatterRules {required = [requiredTarget], recommended = [], optional = []} + (firstTypeRule typeAwareProfileSpec) + ] + } + compiled <- firstShow (compileProfile base) + active <- profileConcept "active" [("type", String "Owned Concept"), ("status", String "active")] "# Active\n" + superseded <- profileConcept "superseded" [("type", String "Owned Concept"), ("status", String "superseded")] "# Superseded\n" + invalidPresent <- profileConcept "invalid-present" [("type", String "Owned Concept"), ("status", String "active"), ("supersededBy", String "ADR-2")] "# Invalid\n" + missingSource <- profileConcept "missing-source" [("type", String "Owned Concept")] "# Missing source\n" + invalidSource <- profileConcept "invalid-source" [("type", String "Owned Concept"), ("status", String "unknown")] "# Invalid source\n" + wrongShapeSource <- profileConcept "wrong-shape-source" [("type", String "Owned Concept"), ("status", toJSON (["active"] :: [Text]))] "# Wrong shape\n" + activeId <- parseTestConceptId "active" + supersededId <- parseTestConceptId "superseded" + invalidId <- parseTestConceptId "invalid-present" + missingSourceId <- parseTestConceptId "missing-source" + invalidSourceId <- parseTestConceptId "invalid-source" + wrongShapeSourceId <- parseTestConceptId "wrong-shape-source" + assertEqual [] (validateProfile PermissiveConformance compiled [active]) + assertEqual + [MissingRecommendedProfileField activeId "supersededBy" (Just (FieldCondition "status" ["active"]))] + (validateProfile StrictAuthoring compiled [active]) + assertEqual + [MissingProfileField supersededId "supersededBy" (Just (FieldCondition "status" ["superseded"]))] + (validateProfile PermissiveConformance compiled [superseded]) + assertEqual + [ValueNotInVocabulary invalidId (fieldPath "supersededBy") ["ADR-1"] (String "ADR-2")] + (validateProfile PermissiveConformance compiled [invalidPresent]) + assertEqual + [MissingProfileField missingSourceId "status" Nothing] + (validateProfile PermissiveConformance compiled [missingSource]) + assertEqual + [ValueNotInVocabulary invalidSourceId (fieldPath "status") ["active", "superseded"] (String "unknown")] + (validateProfile PermissiveConformance compiled [invalidSource]) + assertEqual + [CardinalityMismatch wrongShapeSourceId (fieldPath "status") Scalar (toJSON (["active"] :: [Text]))] + (validateProfile PermissiveConformance compiled [wrongShapeSource]) + +testNestedConditionalPresence :: Either Text () +testNestedConditionalPresence = do + let nestedRules = + NestedRules + { required = + [ NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing Nothing, + NestedFieldRule "provider" Nothing [] Scalar Nothing Nothing (Just (FieldCondition "kind" ["model"])) + ], + recommended = + [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing (Just (FieldCondition "kind" ["human"]))], + optional = [] + } + spec = nestedProfileWithRules List nestedRules Nothing + compiled <- firstShow (compileProfile spec) + concept <- + profileConcept + "conditional-reviews" + [ ("type", String "Reviewed Concept"), + ("reviews", toJSON [object ["kind" .= ("model" :: Text)], object ["kind" .= ("human" :: Text)], object []]) + ] + "# Conditional reviews\n" + cid <- parseTestConceptId "conditional-reviews" + assertEqual + [MissingNestedProfileField cid (nestedTestPath 0 "provider") (Just (FieldCondition "kind" ["model"])), MissingNestedProfileField cid (nestedTestPath 2 "kind") Nothing] + (validateProfile PermissiveConformance compiled [concept]) + assertEqual + [ MissingNestedProfileField cid (nestedTestPath 0 "provider") (Just (FieldCondition "kind" ["model"])), + MissingRecommendedNestedProfileField cid (nestedTestPath 1 "notes") (Just (FieldCondition "kind" ["human"])), + MissingNestedProfileField cid (nestedTestPath 2 "kind") Nothing + ] + (validateProfile StrictAuthoring compiled [concept]) + +testReferenceDefinitionErrors :: Either Text () +testReferenceDefinitionErrors = do + let referenceRule key prefix schemes fieldFormat = + fieldRule + key + Nothing + [] + Scalar + fieldFormat + Nothing + (Just (HandleReferenceRule prefix schemes False)) + Nothing + baseType = firstTypeRule testDocumentIdProfileSpec + specWith profileIdField typeRules profileRules = + testDocumentIdProfileSpec + { frontmatter = FrontmatterRules {required = profileRules, recommended = [], optional = []}, + idField = profileIdField, + requireBundleVersion = Nothing, + types = typeRules + } + path = fieldPath "supersedes" + invalidPrefixType = baseType {idPrefix = Just "1ADR"} + invalidPrefixSpec = specWith (Just "docId") [invalidPrefixType] [referenceRule "supersedes" "1ADR" [] Nothing] + undeclaredPrefixSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "PAT" [] Nothing] + missingIdFieldSpec = specWith Nothing [baseType] [referenceRule "supersedes" "ADR" [] Nothing] + invalidSchemeSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "ADR" ["mori_", "MORI_"] Nothing] + formatSpec = specWith (Just "docId") [baseType] [referenceRule "supersedes" "ADR" [] (Just (DocumentHandle "ADR"))] + typeReference = referenceRule "supersedes" "RFC" [] Nothing + conflictingType :: TypeRule + conflictingType = baseType & #frontmatter .~ FrontmatterRules {required = [typeReference], recommended = [], optional = []} + rfcType = baseType {type_ = "RFC", idPrefix = Just "RFC", pathPattern = Nothing} + conflictSpec = specWith (Just "docId") [conflictingType, rfcType] [referenceRule "supersedes" "ADR" [] Nothing] + assertEqual + (Left (InvalidReferencePrefix Nothing path "1ADR" :| [])) + (compileProfile invalidPrefixSpec) + assertEqual + (Left (ReferencePrefixNotDeclared Nothing path "PAT" :| [])) + (compileProfile undeclaredPrefixSpec) + assertEqual + (Left (ReferenceRequiresIdField Nothing path :| [])) + (compileProfile missingIdFieldSpec) + assertEqual + (Left (InvalidExternalReferenceScheme Nothing path "mori_" :| [])) + (compileProfile invalidSchemeSpec) + assertEqual + (Left (ReferenceWithFormat Nothing path (DocumentHandle "ADR") :| [])) + (compileProfile formatSpec) + assertEqual + (Left (ConflictingReferencePrefix "Decision Record" path "ADR" "RFC" :| [])) + (compileProfile conflictSpec) + +testDocumentReferenceValidation :: Either Text () +testDocumentReferenceValidation = do + let referencePolicy = HandleReferenceRule "ADR" ["mori", "MORI"] False + selfPolicy = HandleReferenceRule "ADR" [] True + referenceRules = + [ fieldRule "references" Nothing [] List Nothing Nothing (Just referencePolicy) Nothing, + fieldRule "selfReference" Nothing [] Scalar Nothing Nothing (Just selfPolicy) Nothing + ] + spec :: ProfileSpec + spec = + testDocumentIdProfileSpec + & #frontmatter + .~ FrontmatterRules + { required = [requiredField "type", requiredField "title"], + recommended = referenceRules, + optional = [] + } + compiled <- firstShow (compileProfile spec) + duplicateA <- decisionConcept "decisions/duplicate-a" "Duplicate A" "ADR-3" [] + duplicateB <- decisionConcept "decisions/duplicate-b" "Duplicate B" "ADR-3" [] + source <- + decisionConcept + "decisions/source" + "Source" + "ADR-1" + [ ( "references", + toJSON + [ String "ADR-2", + String "ADR-99", + String "PAT-3", + String "not a reference", + String "https://example.test/external", + String "MORI://shinzui/okf/docs/one", + String "ADR-1", + Number 7, + String "ADR-3" + ] + ), + ("selfReference", String "ADR-1") + ] + target <- decisionConcept "decisions/target" "Target" "ADR-2" [] + duplicateAId <- parseTestConceptId "decisions/duplicate-a" + duplicateBId <- parseTestConceptId "decisions/duplicate-b" + sourceId <- parseTestConceptId "decisions/source" + assertEqual + [ DanglingHandleReference sourceId (indexedPath "references" 1) "ADR-99", + ReferenceHandlePrefixMismatch sourceId (indexedPath "references" 2) "PAT-3" "ADR", + MalformedDocumentReference sourceId (indexedPath "references" 3) (String "not a reference"), + ExternalReferenceSchemeNotAllowed sourceId (indexedPath "references" 4) "https" ["mori"], + SelfDocumentReference sourceId (indexedPath "references" 6) "ADR-1", + MalformedDocumentReference sourceId (indexedPath "references" 7) (Number 7), + DuplicateDocumentId "ADR-3" duplicateAId duplicateBId + ] + (validateProfile PermissiveConformance compiled [target, source, duplicateB, duplicateA]) + where + decisionConcept cid title documentId extraFields = + profileConcept + cid + ([("type", String "Decision Record"), ("title", String title), ("docId", String documentId)] <> extraFields) + ("# " <> title <> "\n") + indexedPath key elementIndex = FieldPath (FieldName key :| [ArrayIndex elementIndex]) + +-- | The whole point of the third presence list: absence is silent in both +-- validation modes, while a present value is checked exactly as hard as it would +-- be under @required@. +testOptionalFieldPresence :: Either Text () +testOptionalFieldPresence = do + let optionalRules = + [ fieldRule "supersedes" Nothing ["ADR-1", "ADR-2"] Scalar Nothing Nothing Nothing Nothing, + fieldRule "reviewedAt" Nothing [] Any (Just Rfc3339Utc) Nothing Nothing Nothing, + fieldRule "tags" Nothing [] List Nothing Nothing Nothing Nothing + ] + spec = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [requiredField "type"], + recommended = [requiredField "owner"], + optional = optionalRules + }, + allowUnknownTypes = True, + types = [] + } + compiled <- firstShow (compileProfile spec) + absent <- profileConcept "optional/absent" [("type", String "Extension"), ("owner", String "Ari")] "# Absent\n" + -- A correctly shaped empty value counts as absent, so it is as silent as a key + -- that was never written. (A blank value on a field that also declares a + -- vocabulary or format still fails that check; presence and value are + -- independent, which is exactly what this feature relies on.) + emptied <- + profileConcept + "optional/emptied" + [ ("type", String "Extension"), + ("owner", String "Ari"), + ("tags", toJSON ([] :: [Text])) + ] + "# Emptied\n" + valid <- + profileConcept + "optional/valid" + [ ("type", String "Extension"), + ("owner", String "Ari"), + ("supersedes", String "ADR-1"), + ("reviewedAt", String "2026-07-30T00:00:00Z"), + ("tags", toJSON (["profiles"] :: [Text])) + ] + "# Valid\n" + invalid <- + profileConcept + "optional/invalid" + [ ("type", String "Extension"), + ("owner", String "Ari"), + ("supersedes", String "ADR-9"), + ("reviewedAt", String "2026-13-45T99:99:99Z"), + ("tags", String "profiles") + ] + "# Invalid\n" + invalidId <- parseTestConceptId "optional/invalid" + for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> do + assertEqual [] (validateProfile validationProfile compiled [absent]) + assertEqual [] (validateProfile validationProfile compiled [emptied]) + assertEqual [] (validateProfile validationProfile compiled [valid]) + assertEqual + [ ValueFormatMismatch invalidId (fieldPath "reviewedAt") Rfc3339Utc (String "2026-13-45T99:99:99Z"), + ValueNotInVocabulary invalidId (fieldPath "supersedes") ["ADR-1", "ADR-2"] (String "ADR-9"), + CardinalityMismatch invalidId (fieldPath "tags") List (String "profiles") + ] + (validateProfile validationProfile compiled [invalid]) + +-- | An optional field carrying a document-reference policy resolves handles the +-- same way a required one does; only the absence check differs. +testOptionalReferenceValidation :: Either Text () +testOptionalReferenceValidation = do + let spec :: ProfileSpec + spec = + testDocumentIdProfileSpec + & #frontmatter + .~ FrontmatterRules + { required = [requiredField "type", requiredField "title"], + recommended = [], + optional = [fieldRule "supersedes" Nothing [] Scalar Nothing Nothing (Just (HandleReferenceRule "ADR" [] False)) Nothing] + } + compiled <- firstShow (compileProfile spec) + target <- decisionTestConcept "decisions/target" "Target" "ADR-1" [] + silent <- decisionTestConcept "decisions/silent" "Silent" "ADR-2" [] + dangling <- decisionTestConcept "decisions/dangling" "Dangling" "ADR-3" [("supersedes", String "ADR-99")] + danglingId <- parseTestConceptId "decisions/dangling" + for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> do + assertEqual [] (validateProfile validationProfile compiled [target, silent]) + assertEqual + [DanglingHandleReference danglingId (fieldPath "supersedes") "ADR-99"] + (validateProfile validationProfile compiled [target, dangling]) + +-- | Optional members of a list-element record behave the same way inside every +-- record: never missing, always checked when present. +testOptionalNestedFieldPresence :: Either Text () +testOptionalNestedFieldPresence = do + let nestedRules = + NestedRules + { required = [NestedFieldRule "kind" Nothing ["human", "model"] Scalar Nothing Nothing Nothing], + recommended = [NestedFieldRule "notes" Nothing [] Scalar Nothing Nothing Nothing], + optional = [NestedFieldRule "model" Nothing ["opus", "sonnet"] Scalar Nothing Nothing Nothing] + } + compiled <- firstShow (compileProfile (nestedProfileWithRules Any nestedRules Nothing)) + concept <- + profileConcept + "reviewed/optional" + [ ("type", String "Reviewed Concept"), + ( "reviews", + toJSON + [ object ["kind" .= ("human" :: Text), "notes" .= ("looks good" :: Text)], + object ["kind" .= ("model" :: Text), "notes" .= ("ran it" :: Text), "model" .= ("opus" :: Text)], + object ["kind" .= ("model" :: Text), "notes" .= ("ran it" :: Text), "model" .= ("gpt" :: Text)] + ] + ) + ] + "# Optional\n" + cid <- parseTestConceptId "reviewed/optional" + for_ [PermissiveConformance, StrictAuthoring] $ \validationProfile -> + assertEqual + [ValueNotInVocabulary cid (nestedTestPath 2 "model") ["opus", "sonnet"] (String "gpt")] + (validateProfile validationProfile compiled [concept]) + +-- | An optional key is declared for the purposes of field-name closure, so a +-- closed profile accepts it and still catches a misspelling of it. +testOptionalFieldClosure :: Either Text () +testOptionalFieldClosure = do + let closed = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = [requiredField "type"], + recommended = [], + optional = [requiredField "supersedes"] + }, + allowUnknownTypes = True, + allowUnknownFields = False, + types = [] + } + compiled <- firstShow (compileProfile closed) + declared <- profileConcept "closed/declared" [("type", String "Extension"), ("supersedes", String "ADR-1")] "# Declared\n" + typo <- profileConcept "closed/typo" [("type", String "Extension"), ("supersedse", String "ADR-1")] "# Typo\n" + typoId <- parseTestConceptId "closed/typo" + assertEqual [] (validateProfile PermissiveConformance compiled [declared]) + assertEqual + [FieldNotInProfile typoId "supersedse"] + (validateProfile PermissiveConformance compiled [typo]) + +-- | Declaring a key optional at one scope does not cancel the other scope's +-- presence clause. Merging accumulates clauses precisely so a type rule can +-- narrow but never silently weaken a profile-wide expectation. +testOptionalDoesNotCancelOtherScope :: Either Text () +testOptionalDoesNotCancelOtherScope = do + let ownerRule = requiredField "owner" + specWith profileRules typeRules = + typeAwareProfileSpec + { frontmatter = profileRules, + allowUnknownTypes = True, + types = [withTypeFrontmatter typeRules (firstTypeRule typeAwareProfileSpec)] + } + recommendedThenOptional = + specWith + FrontmatterRules {required = [requiredField "type"], recommended = [ownerRule], optional = []} + FrontmatterRules {required = [], recommended = [], optional = [ownerRule]} + optionalThenRecommended = + specWith + FrontmatterRules {required = [requiredField "type"], recommended = [], optional = [ownerRule]} + FrontmatterRules {required = [], recommended = [ownerRule], optional = []} + concept <- profileConcept "owned/one" [("type", String "Owned Concept")] "# One\n" + cid <- parseTestConceptId "owned/one" + for_ [recommendedThenOptional, optionalThenRecommended] $ \spec -> do + compiled <- firstShow (compileProfile spec) + assertEqual [] (validateProfile PermissiveConformance compiled [concept]) + assertEqual + [MissingRecommendedProfileField cid "owner" Nothing] + (validateProfile StrictAuthoring compiled [concept]) + +-- | Compilation rejects the two contradictions the third list makes possible: a +-- key classified twice at one scope, and a condition on a rule that has no +-- presence check for it to gate. +testOptionalDefinitionErrors :: Either Text () +testOptionalDefinitionErrors = do + let key name = requiredField name + specWith rules = + typeAwareProfileSpec {frontmatter = rules, allowUnknownTypes = True, types = []} + conditioned name sourceKey = + fieldRule name Nothing [] Any Nothing Nothing Nothing (Just (FieldCondition sourceKey ["active"])) + statusRule = fieldRule "status" Nothing ["active"] Scalar Nothing Nothing Nothing Nothing + assertEqual + (Left (ConflictingFieldRequirement Nothing "owner" :| [])) + (compileProfile (specWith FrontmatterRules {required = [key "type", key "owner"], recommended = [], optional = [key "owner"]})) + assertEqual + (Left (ConflictingFieldRequirement Nothing "owner" :| [])) + (compileProfile (specWith FrontmatterRules {required = [key "type"], recommended = [key "owner"], optional = [key "owner"]})) + assertEqual + (Left (DuplicateFieldRule Nothing "optional" "owner" :| [])) + (compileProfile (specWith FrontmatterRules {required = [key "type"], recommended = [], optional = [key "owner", key "owner"]})) + assertEqual + (Left (OptionalFieldWithCondition Nothing (fieldPath "supersededBy") :| [])) + ( compileProfile + (specWith FrontmatterRules {required = [key "type", statusRule], recommended = [], optional = [conditioned "supersededBy" "status"]}) + ) + let nestedRules = + NestedRules + { required = [NestedFieldRule "kind" Nothing ["model"] Scalar Nothing Nothing Nothing], + recommended = [], + optional = [NestedFieldRule "model" Nothing [] Scalar Nothing Nothing (Just (FieldCondition "kind" ["model"]))] + } + assertEqual + (Left (OptionalFieldWithCondition Nothing (FieldPath (FieldName "reviews" :| [FieldName "model"])) :| [])) + (compileProfile (nestedProfileWithRules Any nestedRules Nothing)) + let optionalParent = + specWith + FrontmatterRules + { required = [key "type"], + recommended = [], + optional = [fieldRule "reviews" Nothing [] List Nothing (Just nestedRules) Nothing Nothing] + } + assertEqual + (Left (OptionalFieldWithCondition Nothing (FieldPath (FieldName "reviews" :| [FieldName "model"])) :| [])) + (compileProfile optionalParent) + +decisionTestConcept :: Text -> Text -> Text -> [(Text, Value)] -> Either Text Concept +decisionTestConcept cid title documentId extraFields = + profileConcept + cid + ([("type", String "Decision Record"), ("title", String title), ("docId", String documentId)] <> extraFields) + ("# " <> title <> "\n") + +-- | The end-to-end proof, run against the fixture bundle a reader can also run +-- from the command line. Absence of the three optional keys is silent in both +-- modes; the one genuine recommendation still fails under strict authoring; the +-- conditional requirement in the same type still fires; and every optional key +-- that /is/ present is checked as hard as a required one. +testOptionalFieldsFixture :: IO (Either Text ()) +testOptionalFieldsFixture = do + descriptorPath <- fixtureFilePath "profiles/optional-fields.dhall" + conditionPath <- fixtureFilePath "profiles/optional-conditional-invalid.dhall" + collisionPath <- fixtureFilePath "profiles/optional-collision-invalid.dhall" + loaded <- loadProfileFile descriptorPath + conditionLoaded <- loadProfileFile conditionPath + collisionLoaded <- loadProfileFile collisionPath + root <- fixturePath "profile-optional-fields" + concepts <- readBundle root + pure $ do + spec <- first ("failed to load optional-fields profile: " <>) loaded + compiled <- firstShow (compileProfile spec) + conditionSpec <- first ("failed to load invalid optional-condition profile: " <>) conditionLoaded + collisionSpec <- first ("failed to load invalid optional-collision profile: " <>) collisionLoaded + assertEqual + ( Left + ( OptionalFieldWithCondition (Just "Decision Record") (FieldPath (FieldName "reviews" :| [FieldName "model"])) + :| [OptionalFieldWithCondition (Just "Decision Record") (fieldPath "supersededBy")] + ) + ) + (compileProfile conditionSpec) + assertEqual + ( Left + ( ConflictingFieldRequirement Nothing "reviewedBy" + :| [ConflictingFieldRequirement (Just "Decision Record") "owner"] + ) + ) + (compileProfile collisionSpec) + accepted <- parseTestConceptId "decisions/accepted" + badSupersedes <- parseTestConceptId "decisions/bad-supersedes" + superseded <- parseTestConceptId "decisions/superseded" + let valueViolations = + [ ValueFormatMismatch badSupersedes (fieldPath "decidedAt") Rfc3339Utc (String "not a timestamp"), + ValueNotInVocabulary badSupersedes (nestedReviewPath 0 "model") ["opus", "sonnet"] (String "gpt"), + DanglingHandleReference badSupersedes (fieldPath "supersedes") "ADR-99", + MissingProfileField superseded "supersededBy" (Just (FieldCondition "status" ["superseded"])) + ] + assertEqual valueViolations (validateProfile PermissiveConformance compiled concepts) + assertEqual + (MissingRecommendedProfileField accepted "reviewedBy" Nothing : valueViolations) + (validateProfile StrictAuthoring compiled concepts) + where + nestedReviewPath elementIndex key = + FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) + +testClosedFieldValidation :: Either Text () +testClosedFieldValidation = do + let ownedRule :: TypeRule + ownedRule = + withTypeFrontmatter + FrontmatterRules {required = [requiredField "owner"], recommended = [], optional = []} + (firstTypeRule typeAwareProfileSpec) + reviewRule = + withTypeName + "Review" + (withTypeFrontmatter FrontmatterRules {required = [requiredField "reviewer"], recommended = [], optional = []} ownedRule) + closed = + typeAwareProfileSpec + { frontmatter = FrontmatterRules {required = [requiredField "type", requiredField "status"], recommended = [], optional = []}, + allowUnknownFields = False, + idField = Just "requestId", + requireBundleVersion = Nothing, + types = [ownedRule, reviewRule] + } + compiled <- firstShow (compileProfile closed) + typo <- + profileConcept + "owned/typo" + [ ("type", String "Owned Concept"), + ("title", String "Typo"), + ("description", String "Core"), + ("timestamp", String "2026-07-29T00:00:00Z"), + ("resource", String "https://example.test/typo"), + ("tags", toJSON (["profiles"] :: [Text])), + ("requestId", String "IR-1"), + ("owner", String "Ari"), + ("reviewer", String "Bo"), + ("stauts", String "draft") + ] + "# Typo\n" + cid <- parseTestConceptId "owned/typo" + assertEqual + [ MissingProfileField cid "status" Nothing, + FieldNotInProfile cid "reviewer", + FieldNotInProfile cid "stauts" + ] + (validateProfile PermissiveConformance compiled [typo]) + let reopened = closed {allowUnknownFields = True} + reopenedCompiled <- firstShow (compileProfile reopened) + assertEqual + [MissingProfileField cid "status" Nothing] + (validateProfile PermissiveConformance reopenedCompiled [typo]) + +-- | The behavior this plan exists to deliver: a profile can require a +-- mapping-valued key and can demand a member of that mapping, reported at a path +-- such as @generated.by@. +testValidateObjectMember :: Either Text () +testValidateObjectMember = do + compiled <- + firstShow + (compileProfile (objectProfileWithRules "generated" Any (Just provenanceMemberRules) Nothing)) + cid <- parseTestConceptId "thing" + -- A well-formed mapping satisfies the rule and reports nothing at all, which + -- is the half of the fix that the old `missing profile-required field: + -- generated` transcript got wrong. + wellFormed <- + profileConcept + "thing" + [ ("type", String "Thing"), + ("generated", object ["by" .= ("human:nadeem" :: Text), "at" .= ("2026-06-18T00:00:00Z" :: Text)]) + ] + "# Thing\n" + assertEqual [] (validateProfile StrictAuthoring compiled [wellFormed]) + -- A mapping missing the demanded member reports that member, not the parent. + missingMember <- + profileConcept + "thing" + [ ("type", String "Thing"), + ("generated", object ["at" .= ("2026-06-18T00:00:00Z" :: Text)]) + ] + "# Thing\n" + assertEqual + [MissingNestedProfileField cid (objectMemberPath "generated" "by") Nothing] + (validateProfile PermissiveConformance compiled [missingMember]) + -- Members are value-checked exactly as list-element members are, and the + -- recommended member is reported only under strict authoring. + badTimestamp <- + profileConcept + "thing" + [("type", String "Thing"), ("generated", object ["by" .= ("human:nadeem" :: Text), "at" .= ("not-a-time" :: Text)])] + "# Thing\n" + assertEqual + [ValueFormatMismatch cid (objectMemberPath "generated" "at") Rfc3339Utc (String "not-a-time")] + (validateProfile PermissiveConformance compiled [badTimestamp]) + onlyBy <- + profileConcept + "thing" + [("type", String "Thing"), ("generated", object ["by" .= ("human:nadeem" :: Text)])] + "# Thing\n" + assertEqual [] (validateProfile PermissiveConformance compiled [onlyBy]) + assertEqual + [MissingRecommendedNestedProfileField cid (objectMemberPath "generated" "at") Nothing] + (validateProfile StrictAuthoring compiled [onlyBy]) + -- The key itself is still demanded when it is absent entirely, and an empty + -- mapping counts as absent for the same reason an empty list does. + absent <- profileConcept "thing" [("type", String "Thing")] "# Thing\n" + assertEqual + [MissingProfileField cid "generated" Nothing] + (validateProfile PermissiveConformance compiled [absent]) + emptyMapping <- + profileConcept "thing" [("type", String "Thing"), ("generated", object [])] "# Thing\n" + assertEqual + [MissingProfileField cid "generated" Nothing] + (validateProfile PermissiveConformance compiled [emptyMapping]) + +-- | OKF v0.2 specification §5.2 permits @verified@ as a list of mappings or as +-- one bare mapping and requires a consumer to treat the bare mapping as a +-- one-element list. A rule declaring both shapes checks them against the same +-- member rules, and neither spelling is a cardinality mismatch. +testValidateRecordOrList :: Either Text () +testValidateRecordOrList = do + compiled <- + firstShow + ( compileProfile + (objectProfileWithRules "verified" Any (Just provenanceMemberRules) (Just provenanceMemberRules)) + ) + cid <- parseTestConceptId "thing" + bareMapping <- + profileConcept + "thing" + [("type", String "Thing"), ("verified", object ["at" .= ("2026-06-20T00:00:00Z" :: Text)])] + "# Thing\n" + assertEqual + [MissingNestedProfileField cid (objectMemberPath "verified" "by") Nothing] + (validateProfile PermissiveConformance compiled [bareMapping]) + oneElementList <- + profileConcept + "thing" + [("type", String "Thing"), ("verified", toJSON [object ["at" .= ("2026-06-20T00:00:00Z" :: Text)]])] + "# Thing\n" + assertEqual + [ MissingNestedProfileField + cid + (FieldPath (FieldName "verified" :| [ArrayIndex 0, FieldName "by"])) + Nothing + ] + (validateProfile PermissiveConformance compiled [oneElementList]) + -- Both spellings are satisfiable, and neither reports a shape error. + goodMapping <- + profileConcept + "thing" + [("type", String "Thing"), ("verified", object ["by" .= ("human:nadeem" :: Text), "at" .= ("2026-06-20T00:00:00Z" :: Text)])] + "# Thing\n" + assertEqual [] (validateProfile StrictAuthoring compiled [goodMapping]) + +-- | A shape error does not cascade: a value of the wrong shape produces exactly +-- one 'CardinalityMismatch' naming the expected shape, and no member violations +-- from walking a record that is not there. +testValidateObjectWrongShape :: Either Text () +testValidateObjectWrongShape = do + compiled <- + firstShow + (compileProfile (objectProfileWithRules "generated" Any (Just provenanceMemberRules) Nothing)) + cid <- parseTestConceptId "thing" + let listValue = toJSON [object ["by" .= ("human:nadeem" :: Text)]] + concept <- + profileConcept "thing" [("type", String "Thing"), ("generated", listValue)] "# Thing\n" + assertEqual + [CardinalityMismatch cid (fieldPath "generated") Object listValue] + (validateProfile StrictAuthoring compiled [concept]) + +-- | Declaring no member rules at all still demands that the value be a mapping. +-- This is how an author says "this key must be an object" and nothing more, +-- which is the alternative to adding an @Object@ alternative to the published +-- Dhall union. +testValidateEmptyObjectRules :: Either Text () +testValidateEmptyObjectRules = do + compiled <- + firstShow + ( compileProfile + ( objectProfileWithRules + "generated" + Any + (Just (NestedRules {required = [], recommended = [], optional = []})) + Nothing + ) + ) + cid <- parseTestConceptId "thing" + mapping <- + profileConcept + "thing" + [("type", String "Thing"), ("generated", object ["anything" .= ("at all" :: Text)])] + "# Thing\n" + assertEqual [] (validateProfile StrictAuthoring compiled [mapping]) + scalarValue <- + profileConcept "thing" [("type", String "Thing"), ("generated", String "nope")] "# Thing\n" + assertEqual + [CardinalityMismatch cid (fieldPath "generated") Object (String "nope")] + (validateProfile PermissiveConformance compiled [scalarValue]) + +objectMemberPath :: Text -> Text -> FieldPath +objectMemberPath parent key = FieldPath (FieldName parent :| [FieldName key]) + +firstTypeRule :: ProfileSpec -> TypeRule +firstTypeRule spec = + case spec ^. #types of + rule : _ -> rule + [] -> error "test profile unexpectedly has no type rules" + +withTypeFrontmatter :: FrontmatterRules -> TypeRule -> TypeRule +withTypeFrontmatter + replacement + TypeRule + { type_, + description, + pathPattern, + resourceScheme, + requireSchemaSection, + schemaColumns, + idPrefix + } = + TypeRule + { type_, + description, + frontmatter = replacement, + pathPattern, + resourceScheme, + requireSchemaSection, + schemaColumns, + idPrefix + } + +withTypeName :: Text -> TypeRule -> TypeRule +withTypeName + replacement + TypeRule + { description, + frontmatter, + pathPattern, + resourceScheme, + requireSchemaSection, + schemaColumns, + idPrefix + } = + TypeRule + { type_ = replacement, + description, + frontmatter, + pathPattern, + resourceScheme, + requireSchemaSection, + schemaColumns, + idPrefix + } + +testProfileRulesApplyToUnknownTypes :: Either Text () +testProfileRulesApplyToUnknownTypes = do + compiled <- firstShow (compileProfile typeAwareProfileSpec) + concept <- profileConcept "extensions/one" [("type", String "Extension Concept")] "# One\n" + cid <- parseTestConceptId "extensions/one" + assertEqual + [MissingProfileField cid "title" Nothing] + (validateProfile PermissiveConformance compiled [concept]) + +testStrictProfileRecommendations :: Either Text () +testStrictProfileRecommendations = do + compiled <- firstShow (compileProfile typeAwareProfileSpec) + concept <- + profileConcept + "owned/one" + [("type", String "Owned Concept"), ("title", String "One"), ("owner", String "Ari")] + "# One\n" + cid <- parseTestConceptId "owned/one" + assertEqual [] (validateProfile PermissiveConformance compiled [concept]) + assertEqual + [MissingRecommendedProfileField cid "reviewer" Nothing] + (validateProfile StrictAuthoring compiled [concept]) + +-- | Build an in-memory concept from a raw ID, frontmatter pairs, and a body. +profileConcept :: Text -> [(Text, Value)] -> Text -> Either Text Concept +profileConcept rawId fieldPairs bodyText = do + conceptId <- parseTestConceptId rawId + pure (conceptFromDocument conceptId (OKFDocument (frontmatterFromFields fieldPairs) bodyText)) + +-- | A well-formed @# Schema@ section matching the profile's required columns. +schemaSectionBody :: Text +schemaSectionBody = + Text.unlines + [ "# Schema", + "", + "| Column | Type | Nullable | Description |", + "|--------|--------|----------|-------------|", + "| id | bigint | no | Primary key |" + ] + +testProfileConformingTable :: Either Text () +testProfileConformingTable = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [ ("type", String "PostgreSQL Table"), + ("title", String "Orders"), + ("resource", String "postgresql://warehouse/sales/orders") + ] + schemaSectionBody + assertEqual [] (validateTestProfile testProfileSpec [concept]) + +testProfileUnknownType :: Either Text () +testProfileUnknownType = do + concept <- + profileConcept + "schemas/sales/tables/bad" + [("type", String "pg table"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/bad" + assertEqual + [TypeNotInProfile cid "pg table", MissingProfileField cid "title" Nothing] + (validateTestProfile testProfileSpec [concept]) + +testProfileMissingField :: Either Text () +testProfileMissingField = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual [MissingProfileField cid "title" Nothing] (validateTestProfile testProfileSpec [concept]) + +testProfileResourceMismatch :: Either Text () +testProfileResourceMismatch = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "mysql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [ResourceSchemeMismatch cid "postgresql" "mysql://x"] + (validateTestProfile testProfileSpec [concept]) + +testProfilePathMismatch :: Either Text () +testProfilePathMismatch = do + concept <- + profileConcept + "tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "tables/orders" + assertEqual + [PathPatternMismatch cid "PostgreSQL Table" "schemas/*/tables/*"] + (validateTestProfile testProfileSpec [concept]) + +testProfileMissingSchema :: Either Text () +testProfileMissingSchema = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + "# Overview\n\nNo schema section here.\n" + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [MissingSchemaSection cid "PostgreSQL Table"] + (validateTestProfile testProfileSpec [concept]) + +testProfileSchemaColumnsMismatch :: Either Text () +testProfileSchemaColumnsMismatch = do + let mismatchBody = + Text.unlines + ["# Schema", "", "| Col | Type |", "|-----|------|", "| id | bigint |"] + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + mismatchBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [SchemaColumnsMismatch cid "PostgreSQL Table" ["Column", "Type", "Nullable", "Description"] ["Col", "Type"]] + (validateTestProfile testProfileSpec [concept]) + +testProfileConformingDocumentId :: Either Text () +testProfileConformingDocumentId = do + concept <- + profileConcept + "decisions/one" + [("type", String "Decision Record"), ("title", String "One"), ("docId", String "ADR-1")] + "# One\n" + assertEqual [] (validateTestProfile testDocumentIdProfileSpec [concept]) + +testProfileMissingDocumentId :: Either Text () +testProfileMissingDocumentId = do + concept <- + profileConcept + "decisions/one" + [("type", String "Decision Record"), ("title", String "One")] + "# One\n" + cid <- parseTestConceptId "decisions/one" + assertEqual + [MissingDocumentId cid "Decision Record" "ADR"] + (validateTestProfile testDocumentIdProfileSpec [concept]) + +testProfileMalformedDocumentIds :: Either Text () +testProfileMalformedDocumentIds = do + leadingZero <- + profileConcept + "decisions/leading-zero" + [("type", String "Decision Record"), ("title", String "Leading zero"), ("docId", String "ADR-007")] + "# Leading zero\n" + wrongPrefix <- + profileConcept + "decisions/wrong-prefix" + [("type", String "Decision Record"), ("title", String "Wrong prefix"), ("docId", String "RFC-1")] + "# Wrong prefix\n" + leadingZeroId <- parseTestConceptId "decisions/leading-zero" + wrongPrefixId <- parseTestConceptId "decisions/wrong-prefix" + assertEqual + [ MalformedDocumentId leadingZeroId "ADR" "ADR-007", + MalformedDocumentId wrongPrefixId "ADR" "RFC-1" + ] + (validateTestProfile testDocumentIdProfileSpec [leadingZero, wrongPrefix]) + +testProfileDuplicateDocumentIds :: Either Text () +testProfileDuplicateDocumentIds = do + second <- + profileConcept + "decisions/second" + [("type", String "Decision Record"), ("title", String "Second"), ("docId", String "ADR-1")] + "# Second\n" + firstConcept <- + profileConcept + "decisions/first" + [("type", String "Decision Record"), ("title", String "First"), ("docId", String "ADR-1")] + "# First\n" + firstId <- parseTestConceptId "decisions/first" + secondId <- parseTestConceptId "decisions/second" + assertEqual + [DuplicateDocumentId "ADR-1" firstId secondId] + (validateTestProfile testDocumentIdProfileSpec [second, firstConcept]) + +testProfileDocumentIdsOffByDefault :: Either Text () +testProfileDocumentIdsOffByDefault = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [ ("type", String "PostgreSQL Table"), + ("title", String "Orders"), + ("resource", String "postgresql://warehouse/sales/orders"), + ("docId", String "not-a-handle") + ] + schemaSectionBody + assertEqual [] (validateTestProfile testProfileSpec [concept]) + +testSchemaSectionColumns :: Either Text () +testSchemaSectionColumns = + assertEqual + (Just ["Column", "Type", "Nullable", "Description"]) + (schemaSectionColumns schemaSectionBody) + +-- | Milestone 5: walking the deviating fixture and validating it against the +-- shipped descriptor produces exactly the expected advisory deviations. +testProfileDeviationsFixture :: IO (Either Text ()) +testProfileDeviationsFixture = do + descriptorPath <- fixtureFilePath "profiles/postgresql.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-deviations" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load profile: " <> err) + Right spec -> do + badId <- parseTestConceptId "schemas/sales/tables/bad" + ordersId <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [TypeNotInProfile badId "pg table", MissingProfileField ordersId "title" Nothing] + (validateTestProfile spec concepts) + +testDocumentIdDeviationsFixture :: IO (Either Text ()) +testDocumentIdDeviationsFixture = do + descriptorPath <- fixtureFilePath "profiles/decisions.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "doc-id-deviations" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load document ID profile: " <> err) + Right spec -> do + firstId <- parseTestConceptId "decisions/first" + secondId <- parseTestConceptId "decisions/second" + thirdId <- parseTestConceptId "decisions/third" + fourthId <- parseTestConceptId "decisions/fourth" + assertEqual + [ MissingDocumentId fourthId "Decision Record" "ADR", + MalformedDocumentId thirdId "ADR" "ADR-007", + DuplicateDocumentId "ADR-1" firstId secondId + ] + (validateTestProfile spec concepts) + +testTypeAwareProfileFixture :: IO (Either Text ()) +testTypeAwareProfileFixture = do + descriptorPath <- fixtureFilePath "profiles/type-frontmatter.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-type-frontmatter" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load type-aware profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + ownedId <- parseTestConceptId "owned" + assertEqual [] (validateProfile PermissiveConformance compiled concepts) + assertEqual + [MissingRecommendedProfileField ownedId "reviewer" Nothing] + (validateProfile StrictAuthoring compiled concepts) + +-- | Declaration order is the author's; 'compiledProfileTypeNames' must not +-- reorder it, because generated documentation follows it. +testCompiledProfileTypeNames :: IO (Either Text ()) +testCompiledProfileTypeNames = do + descriptorPath <- fixtureFilePath "profiles/type-frontmatter.dhall" + loaded <- loadProfileFile descriptorPath + pure $ case loaded of + Left err -> Left ("failed to load type-aware profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + assertEqual ["Owned Concept", "Open Concept"] (compiledProfileTypeNames compiled) + +-- | The merged view is what a reader of the profile actually needs: the type +-- rule names two keys, but four apply. +testCompiledProfileRulesMergeTypeScope :: IO (Either Text ()) +testCompiledProfileRulesMergeTypeScope = do + descriptorPath <- fixtureFilePath "profiles/type-frontmatter.dhall" + loaded <- loadProfileFile descriptorPath + pure $ case loaded of + Left err -> Left ("failed to load type-aware profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + let owned = compiledProfileRulesForType compiled "Owned Concept" + assertEqual ["owner", "reviewer", "title", "type"] (Map.keys owned) + ownerRule <- lookupCompiledRule "owner" owned + assertEqual [(RequiredField, Nothing)] (presenceSummary ownerRule) + reviewerRule <- lookupCompiledRule "reviewer" owned + assertEqual [(RecommendedField, Nothing)] (presenceSummary reviewerRule) + titleRule <- lookupCompiledRule "title" owned + assertEqual (Just "Human-readable concept title.") (fieldRuleDescription titleRule) + assertEqual ["title", "type"] (Map.keys (compiledProfileRulesForType compiled "Open Concept")) + assertEqual + (compiledProfileBaseRules compiled) + (compiledProfileRulesForType compiled "Not In Profile") + +-- | Pins the encoding an outside consumer is most likely to misread: @optional@ +-- is an empty presence-clause list, not a constructor. +testCompiledProfileOptionalPresence :: IO (Either Text ()) +testCompiledProfileOptionalPresence = do + descriptorPath <- fixtureFilePath "profiles/optional-fields.dhall" + loaded <- loadProfileFile descriptorPath + pure $ case loaded of + Left err -> Left ("failed to load optional-field profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + let rules = compiledProfileRulesForType compiled "Decision Record" + for_ ["supersedes", "decidedAt", "reviews", "originatingPlan"] $ \key -> do + rule <- lookupCompiledRule key rules + assertEqual [] (presenceSummary rule) + statusRule <- lookupCompiledRule "status" rules + assertEqual [(RequiredField, Nothing)] (presenceSummary statusRule) + assertEqual ["accepted", "superseded"] (fieldRuleAllowedValues statusRule) + assertEqual Scalar (fieldRuleCardinality statusRule) + supersededByRule <- lookupCompiledRule "supersededBy" rules + assertEqual + [(RequiredField, Just (FieldCondition "status" ["superseded"]))] + (presenceSummary supersededByRule) + supersedesRule <- lookupCompiledRule "supersedes" rules + assertEqual + (Just (HandleReferenceRule "ADR" [] False)) + (fieldRuleReference supersedesRule) + reviewsRule <- lookupCompiledRule "reviews" rules + nested <- maybe (Left "reviews declares no element fields") Right (fieldRuleElementFields reviewsRule) + assertEqual ["kind", "model"] (Map.keys nested) + kindRule <- lookupCompiledRule "kind" nested + assertEqual [(RequiredField, Nothing)] (presenceSummary kindRule) + assertEqual Nothing (fieldRuleElementFields kindRule) + modelRule <- lookupCompiledRule "model" nested + assertEqual [] (presenceSummary modelRule) + +lookupCompiledRule :: Text -> Map Text EffectiveFieldRule -> Either Text EffectiveFieldRule +lookupCompiledRule key rules = + maybe (Left ("no compiled rule for key " <> key)) Right (Map.lookup key rules) + +-- | An 'EffectiveFieldRule' is abstract, so summarize its presence clauses +-- through the public accessors into something comparable. +presenceSummary :: EffectiveFieldRule -> [(FieldRequirement, Maybe FieldCondition)] +presenceSummary rule = + [ (presenceClauseRequirement clause, presenceClauseCondition clause) + | clause <- fieldRulePresenceClauses rule + ] + +-- * Profile documentation rendering + +-- | Load a fixture profile, compile it, render documentation, and hand both the +-- compiled profile and the concepts to an assertion. +withRenderedProfileDocumentation :: + FilePath -> + DocumentationOptions -> + (CompiledProfile -> [Concept] -> Either Text ()) -> + IO (Either Text ()) +withRenderedProfileDocumentation fixture options assertion = do + descriptorPath <- fixtureFilePath fixture + loaded <- loadProfileFile descriptorPath + pure $ case loaded of + Left err -> Left ("failed to load profile " <> Text.pack fixture <> ": " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + concepts <- firstShow (renderProfileDocumentation options compiled) + assertion compiled concepts + +conceptBodyLines :: Concept -> [Text] +conceptBodyLines concept = Text.lines (conceptDocument concept ^. #body) + +-- | Assert on whole lines rather than substrings, so a failure names the line +-- that changed instead of pointing at an opaque haystack. +assertHasLine :: Text -> [Text] -> Either Text () +assertHasLine expected bodyLines = + assertBool + ("expected body line " <> Text.pack (show expected)) + (expected `elem` bodyLines) + +conceptAt :: Int -> [Concept] -> Either Text Concept +conceptAt offset concepts = + case drop offset concepts of + concept : _ -> Right concept + [] -> Left ("no concept at position " <> Text.pack (show offset)) + +testProfileDocumentationSlug :: Either Text () +testProfileDocumentationSlug = do + assertEqual "bigquery-table" (profileDocumentationSlug "BigQuery Table") + assertEqual "decision-record" (profileDocumentationSlug "Decision Record") + assertEqual "c-header" (profileDocumentationSlug "C++ Header") + assertEqual "spaced-out" (profileDocumentationSlug " spaced out ") + assertEqual "adr-7" (profileDocumentationSlug "ADR-7") + assertEqual "" (profileDocumentationSlug "###") + +-- | A profile with no rules at all beyond a required @type@, used to exercise +-- layout concerns without dragging in field rendering. +plainDocumentationTypeRule :: Text -> TypeRule +plainDocumentationTypeRule typeName = + TypeRule + { type_ = typeName, + description = Nothing, + frontmatter = FrontmatterRules {required = [], recommended = [], optional = []}, + pathPattern = Nothing, + resourceScheme = Nothing, + requireSchemaSection = False, + schemaColumns = [], + idPrefix = Nothing + } + +-- | Two distinct @type@ strings that slug identically, plus one that slugs to +-- nothing at all. No shipped descriptor has this shape, so the spec is built in +-- Haskell rather than by editing a fixture. +duplicateSlugProfileSpec :: ProfileSpec +duplicateSlugProfileSpec = + ProfileSpec + { name = "duplicate-slugs", + description = Nothing, + okfVersion = "0.1", + frontmatter = + FrontmatterRules + { required = [fieldRule "type" Nothing [] Any Nothing Nothing Nothing Nothing], + recommended = [], + optional = [] + }, + allowUnknownTypes = False, + allowUnknownFields = True, + idField = Nothing, + requireBundleVersion = Nothing, + types = + [ plainDocumentationTypeRule "Decision Record", + plainDocumentationTypeRule "decision record", + plainDocumentationTypeRule "###" + ] + } + +testProfileDocumentationSlugCollisions :: Either Text () +testProfileDocumentationSlugCollisions = do + compiled <- firstShow (compileProfile duplicateSlugProfileSpec) + concepts <- firstShow (renderProfileDocumentation defaultDocumentationOptions compiled) + assertEqual + ["profile", "types/decision-record", "types/decision-record-2", "types/type-3"] + (map (renderConceptId . conceptIdOf) concepts) + +testProfileValueDisplayNames :: Either Text () +testProfileValueDisplayNames = do + assertEqual "any" (renderCardinalityName Any) + assertEqual "scalar" (renderCardinalityName Scalar) + assertEqual "list" (renderCardinalityName List) + assertEqual "rfc3339-utc" (renderFieldFormatName Rfc3339Utc) + assertEqual "date" (renderFieldFormatName Date) + assertEqual "uri" (renderFieldFormatName Uri) + assertEqual "uri-with-scheme(mori)" (renderFieldFormatName (UriWithScheme "mori")) + assertEqual "document-handle(ADR)" (renderFieldFormatName (DocumentHandle "ADR")) + +testProfileDocumentationRootConcept :: IO (Either Text ()) +testProfileDocumentationRootConcept = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + ( \compiled concepts -> do + assertEqual (1 + length (compiledProfileTypeNames compiled)) (length concepts) + root <- conceptAt 0 concepts + assertEqual "profile" (renderConceptId (conceptIdOf root)) + assertEqual profileConceptType (conceptType root) + assertEqual (Just "optional-fields") (conceptTitle root) + let bodyLines = conceptBodyLines root + assertHasLine "# optional-fields" bodyLines + assertHasLine "- [Decision Record](/types/decision-record.md)" bodyLines + assertHasLine "- Document ID field: `docId`" bodyLines + assertHasLine "- Unknown concept types: rejected" bodyLines + assertHasLine "- Unknown frontmatter keys: rejected" bodyLines + -- Every profile-level setting has a bullet whether or not the profile + -- sets it, so a reader learns the setting exists and that this profile + -- leaves it alone. This fixture declares no bundle-version requirement. + assertHasLine "- Required bundle version: none" bodyLines + ) + +-- | A profile setting the renderer does not print is a silent hole in generated +-- documentation, so @requireBundleVersion@ is rendered in the same change that +-- adds it — the rule stated in +-- @docs\/adr\/11-growing-the-profile-descriptor-language.md@. +testProfileDocumentationRequiredBundleVersion :: Either Text () +testProfileDocumentationRequiredBundleVersion = do + compiled <- firstShow (compileProfile (requireBundleVersionProfile (Just "0.2"))) + concepts <- firstShow (renderProfileDocumentation defaultDocumentationOptions compiled) + root <- conceptAt 0 concepts + assertHasLine "- Required bundle version: `0.2`" (conceptBodyLines root) + +-- | A rule kind the renderer does not know about is a silent hole in generated +-- profile documentation, so object rules are rendered in the same change that +-- creates them. The bullet list is fixed by design, so a key that declares no +-- object shape says so explicitly rather than omitting the bullet. +testProfileDocumentationObjectFields :: Either Text () +testProfileDocumentationObjectFields = do + compiled <- + firstShow + (compileProfile (objectProfileWithRules "generated" Any (Just provenanceMemberRules) Nothing)) + concepts <- firstShow (renderProfileDocumentation defaultDocumentationOptions compiled) + root <- conceptAt 0 concepts + let bodyLines = conceptBodyLines root + assertHasLine "- Object fields:" bodyLines + assertHasLine + " - `by` — required; allowed values: any; cardinality: any; format: none — Who or what produced this content." + bodyLines + assertHasLine + " - `at` — recommended; allowed values: any; cardinality: any; format: rfc3339-utc" + bodyLines + assertHasLine "- Element fields: none" bodyLines + assertHasLine "- Cardinality: object" bodyLines + -- A key with no object shape still carries the bullet, so the shape of the + -- list never shifts between rules. + assertHasLine "- Object fields: none" bodyLines + +testProfileDocumentationTypeConcept :: IO (Either Text ()) +testProfileDocumentationTypeConcept = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + ( \_compiled concepts -> do + typeConcept <- conceptAt 1 concepts + assertEqual "types/decision-record" (renderConceptId (conceptIdOf typeConcept)) + assertEqual profileTypeConceptType (conceptType typeConcept) + assertEqual (Just "Decision Record") (conceptTitle typeConcept) + let bodyLines = conceptBodyLines typeConcept + assertHasLine "# Decision Record" bodyLines + assertHasLine "Declared by the [optional-fields](/profile.md) profile." bodyLines + assertHasLine "- Document ID prefix: `ADR`" bodyLines + assertHasLine "- Path pattern: `decisions/*`" bodyLines + assertHasLine "#### `status` — required" bodyLines + assertHasLine "#### `supersededBy` — required when `status` is `superseded`" bodyLines + assertHasLine "- Allowed values: `accepted`, `superseded`" bodyLines + assertHasLine "#### `reviewedBy` — recommended" bodyLines + assertHasLine "- Checked only under `--strict`" bodyLines + assertHasLine "- Format: rfc3339-utc" bodyLines + assertHasLine + " - `kind` — required; allowed values: `human`, `model`; cardinality: scalar; format: none" + bodyLines + assertHasLine + "- Reference: local handles with prefix `ADR`; external URIs not allowed; self-reference not allowed" + bodyLines + -- The profile-scope optional key must appear on the type page, under + -- Optional: this is the merge being visible, which is the whole point. + optionalHeading <- lineIndex "### Optional" bodyLines + inheritedKey <- lineIndex "#### `originatingPlan` — optional" bodyLines + assertBool + "profile-scope optional key falls under the Optional heading" + (optionalHeading < inheritedKey) + ) + where + lineIndex needle bodyLines = + case List.elemIndex needle bodyLines of + Just found -> Right found + Nothing -> Left ("expected body line " <> Text.pack (show needle)) + +testProfileDocumentationInheritedRules :: IO (Either Text ()) +testProfileDocumentationInheritedRules = + withRenderedProfileDocumentation + "profiles/type-frontmatter.dhall" + defaultDocumentationOptions + ( \_compiled concepts -> do + assertEqual + ["profile", "types/owned-concept", "types/open-concept"] + (map (renderConceptId . conceptIdOf) concepts) + owned <- conceptAt 1 concepts + assertHasLine "#### `owner` — required" (conceptBodyLines owned) + assertHasLine "#### `reviewer` — recommended" (conceptBodyLines owned) + -- "Open Concept" declares no frontmatter of its own, so everything on + -- its page is inherited from profile scope. + open <- conceptAt 2 concepts + let openBody = conceptBodyLines open + assertEqual (Just "Open Concept") (conceptTitle open) + assertHasLine "#### `title` — required" openBody + assertHasLine "#### `type` — required" openBody + assertHasLine "### Recommended" openBody + assertHasLine "(none)" openBody + ) + +testProfileDocumentationRoundTrip :: IO (Either Text ()) +testProfileDocumentationRoundTrip = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + ( \_compiled concepts -> + for_ concepts $ \concept -> do + reparsed <- firstShow (parseDocument (serializeConcept concept)) + assertEqual (conceptDocument concept) reparsed + ) + +testProfileDocumentationValidates :: IO (Either Text ()) +testProfileDocumentationValidates = do + permissive <- + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + (\_compiled concepts -> assertEqual [] (validateInMemoryBundle PermissiveConformance VersionUndeclared concepts)) + -- The default options carry a @generated@ family, so strict validation of + -- default output passes with no extra flag: that is the whole point of the + -- default. The v0.1 @timestamp@ spelling still satisfies strict authoring too. + strictResult <- + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + (\_compiled concepts -> assertEqual [] (validateInMemoryBundle StrictAuthoring VersionUndeclared concepts)) + strictLegacyResult <- + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions {generated = Nothing, timestamp = Just "2026-07-31T00:00:00Z"} + (\_compiled concepts -> assertEqual [] (validateInMemoryBundle StrictAuthoring VersionUndeclared concepts)) + pure (permissive >> strictResult >> strictLegacyResult) + +-- | Re-parse the serialized document, so the assertion proves the family +-- survives serialization rather than merely living in the in-memory value. +reparsedGenerated :: Concept -> Either Text (Maybe Generated) +reparsedGenerated concept = do + reparsed <- firstShow (parseDocument (serializeConcept concept)) + pure (readGenerated (reparsed ^. #frontmatter)) + +testProfileDocumentationDefaultGenerated :: IO (Either Text ()) +testProfileDocumentationDefaultGenerated = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + ( \_compiled concepts -> for_ concepts $ \concept -> do + assertEqual + (Just (Generated (ProcessActor "okf-profile-document") Nothing)) + (conceptGenerated concept) + roundTripped <- reparsedGenerated concept + assertEqual + (Just (Generated (ProcessActor "okf-profile-document") Nothing)) + roundTripped + ) + +testProfileDocumentationExplicitGenerated :: IO (Either Text ()) +testProfileDocumentationExplicitGenerated = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + { generated = Just (Generated (HumanActor "nadeem") (Just "2026-08-01T00:00:00Z")) + } + ( \_compiled concepts -> for_ concepts $ \concept -> do + roundTripped <- reparsedGenerated concept + assertEqual + (Just (Generated (HumanActor "nadeem") (Just "2026-08-01T00:00:00Z"))) + roundTripped + ) + +-- | The escape hatch: a caller who wants no provenance at all gets none. +testProfileDocumentationOmittedGenerated :: IO (Either Text ()) +testProfileDocumentationOmittedGenerated = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions {generated = Nothing} + ( \_compiled concepts -> for_ concepts $ \concept -> do + assertEqual Nothing (conceptGenerated concept) + roundTripped <- reparsedGenerated concept + assertEqual Nothing roundTripped + ) + +testProfileDocumentationLinksResolve :: IO (Either Text ()) +testProfileDocumentationLinksResolve = + withRenderedProfileDocumentation + "profiles/optional-fields.dhall" + defaultDocumentationOptions + ( \_compiled concepts -> do + assertEqual [] (danglingReferences concepts) + rootId <- parseTestConceptId "profile" + typeId <- parseTestConceptId "types/decision-record" + let graphEdges = buildGraph concepts ^. #edges + assertBool + "profile links to the type document" + (Edge rootId typeId `elem` graphEdges) + assertBool + "the type document links back to the profile" + (Edge typeId rootId `elem` graphEdges) + ) + +testProfileDocumentationByteStable :: IO (Either Text ()) +testProfileDocumentationByteStable = do + descriptorPath <- fixtureFilePath "profiles/optional-fields.dhall" + loaded <- loadProfileFile descriptorPath + pure $ case loaded of + Left err -> Left ("failed to load optional-field profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + firstRender <- firstShow (renderProfileDocumentation defaultDocumentationOptions compiled) + secondRender <- firstShow (renderProfileDocumentation defaultDocumentationOptions compiled) + assertEqual firstRender secondRender + -- Compare the serialized text too: serializeDocument sorts frontmatter + -- keys, so a Concept-only comparison would miss a nondeterministic + -- serialization. + assertEqual (map serializeConcept firstRender) (map serializeConcept secondRender) + +-- | The generated bundle must survive the round trip the next plan's @--write@ +-- mode performs: write it out, generate indexes over it, walk it back. +testProfileDocumentationFilesystemRoundTrip :: IO (Either Text ()) +testProfileDocumentationFilesystemRoundTrip = do + descriptorPath <- fixtureFilePath "profiles/optional-fields.dhall" + loaded <- loadProfileFile descriptorPath + case loaded >>= (firstShow . compileProfile) of + Left err -> pure (Left ("failed to prepare optional-field profile: " <> err)) + Right compiled -> + case renderProfileDocumentation defaultDocumentationOptions compiled of + Left err -> pure (Left ("render failed: " <> Text.pack (show err))) + Right concepts -> do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-profile-documentation" + writeBundle root concepts + indexResult <- writeBundleIndexes root + walked <- walkBundle root + removeDirectoryRecursive root + pure $ do + _ <- firstShow indexResult + walkedConcepts <- firstShow walked + assertEqual + (List.sort (map (renderConceptId . conceptIdOf) concepts)) + (List.sort (map (renderConceptId . conceptIdOf) walkedConcepts)) + +testClosedFieldsFixture :: IO (Either Text ()) +testClosedFieldsFixture = do + descriptorPath <- fixtureFilePath "profiles/closed-fields.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-closed-fields" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load closed-field profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + typoId <- parseTestConceptId "requests/typo" + assertEqual + [MissingProfileField typoId "status" Nothing, FieldNotInProfile typoId "stauts"] + (validateProfile PermissiveConformance compiled concepts) + +testCardinalityFixture :: IO (Either Text ()) +testCardinalityFixture = do + descriptorPath <- fixtureFilePath "profiles/cardinality.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-cardinality" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load cardinality profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + badId <- parseTestConceptId "bad" + assertEqual + [ CardinalityMismatch badId (fieldPath "tags") List (String "one"), + CardinalityMismatch badId (fieldPath "title") Scalar (toJSON (["One", "Two"] :: [Text])) + ] + (validateProfile PermissiveConformance compiled concepts) + +testFormatsFixture :: IO (Either Text ()) +testFormatsFixture = do + descriptorPath <- fixtureFilePath "profiles/formats.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-formats" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load format profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + badId <- parseTestConceptId "bad" + assertEqual + [ ValueFormatMismatch badId (fieldPath "docId") (DocumentHandle "ADR") (String "ADR-007"), + ValueFormatMismatch badId (fieldPath "homepage") (UriWithScheme "https") (String "mailto:owner@example.test"), + ValueFormatMismatch badId (fieldPath "links") Uri (toJSON (["https://example.test/good", "https://example.test/bad%ZZ"] :: [Text])), + ValueFormatMismatch badId (fieldPath "published") Date (String "2026-13-45"), + ValueFormatMismatch badId (fieldPath "timestamp") Rfc3339Utc (String "2026-07-29T17:00:00+01:00") + ] + (validateProfile PermissiveConformance compiled concepts) + +testNestedReviewsFixture :: IO (Either Text ()) +testNestedReviewsFixture = do + descriptorPath <- fixtureFilePath "profiles/nested-reviews.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-nested-reviews" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load nested review profile: " <> err) + Right spec -> do + compiled <- firstShow (compileProfile spec) + badId <- parseTestConceptId "bad" + let permissiveExpected = + [ NestedElementNotRecord badId (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), + CardinalityMismatch badId (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), + MissingNestedProfileField badId (nestedTestPath 2 "outcome") Nothing, + ValueFormatMismatch badId (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), + ValueNotInVocabulary badId (nestedTestPath 2 "scope") reviewScopes (String "invalid") + ] + assertEqual permissiveExpected (validateProfile PermissiveConformance compiled concepts) + assertEqual + [ NestedElementNotRecord badId (FieldPath (FieldName "reviews" :| [ArrayIndex 1])) (String "not-a-record"), + CardinalityMismatch badId (nestedTestPath 2 "context") Scalar (toJSON (["wrong"] :: [Text])), + MissingRecommendedNestedProfileField badId (nestedTestPath 2 "notes") Nothing, + MissingNestedProfileField badId (nestedTestPath 2 "outcome") Nothing, + ValueFormatMismatch badId (nestedTestPath 2 "reviewed_at") Rfc3339Utc (String "2026-13-45T99:99:99Z"), + ValueNotInVocabulary badId (nestedTestPath 2 "scope") reviewScopes (String "invalid") + ] + (validateProfile StrictAuthoring compiled concepts) + +testConditionalFieldsFixture :: IO (Either Text ()) +testConditionalFieldsFixture = do + descriptorPath <- fixtureFilePath "profiles/conditional-fields.dhall" + invalidDescriptorPath <- fixtureFilePath "profiles/conditional-fields-invalid.dhall" + loaded <- loadProfileFile descriptorPath + invalidLoaded <- loadProfileFile invalidDescriptorPath + root <- fixturePath "profile-conditions" + concepts <- readBundle root + pure $ do + spec <- first ("failed to load conditional profile: " <>) loaded + compiled <- firstShow (compileProfile spec) + invalidSpec <- first ("failed to load invalid conditional profile: " <>) invalidLoaded + decisionsMissingStatus <- parseTestConceptId "decisions/missing-status" + decisionsSuperseded <- parseTestConceptId "decisions/superseded" + postgresqlOperational <- parseTestConceptId "postgresql/operational" + postgresqlProjection <- parseTestConceptId "postgresql/projection" + reviewsMixed <- parseTestConceptId "reviews/mixed" + assertEqual + ( Left + ( ConditionFieldHasUnreachableValues + Nothing + (fieldPath "supersededBy") + (fieldPath "status") + ["superseded"] + ["active"] + :| [] + ) + ) + (compileProfile invalidSpec) + assertEqual + [ MissingProfileField decisionsMissingStatus "status" Nothing, + MissingProfileField decisionsSuperseded "supersededBy" (Just (FieldCondition "status" ["superseded"])), + MissingProfileField postgresqlProjection "sourceQuery" (Just (FieldCondition "derivationKind" ["projection"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "effort") (Just (FieldCondition "kind" ["model"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "model") (Just (FieldCondition "kind" ["model"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "provider") (Just (FieldCondition "kind" ["model"])) + ] + (validateProfile PermissiveConformance compiled concepts) + assertEqual + [ MissingProfileField decisionsMissingStatus "status" Nothing, + MissingProfileField decisionsSuperseded "supersededBy" (Just (FieldCondition "status" ["superseded"])), + MissingRecommendedProfileField postgresqlOperational "runbook" (Just (FieldCondition "derivationKind" ["operational"])), + MissingProfileField postgresqlProjection "sourceQuery" (Just (FieldCondition "derivationKind" ["projection"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "effort") (Just (FieldCondition "kind" ["model"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "model") (Just (FieldCondition "kind" ["model"])), + MissingNestedProfileField reviewsMixed (nestedReviewPath 0 "provider") (Just (FieldCondition "kind" ["model"])) + ] + (validateProfile StrictAuthoring compiled concepts) + where + nestedReviewPath elementIndex key = + FieldPath (FieldName "reviews" :| [ArrayIndex elementIndex, FieldName key]) + +testDocumentReferencesFixture :: IO (Either Text ()) +testDocumentReferencesFixture = do + descriptorPath <- fixtureFilePath "profiles/document-references.dhall" + invalidDescriptorPath <- fixtureFilePath "profiles/document-references-invalid.dhall" + loaded <- loadProfileFile descriptorPath + invalidLoaded <- loadProfileFile invalidDescriptorPath + root <- fixturePath "profile-document-references" + concepts <- readBundle root + pure $ do + spec <- first ("failed to load document-reference profile: " <>) loaded + compiled <- firstShow (compileProfile spec) + invalidSpec <- first ("failed to load invalid document-reference profile: " <>) invalidLoaded + case compileProfile invalidSpec of + Left _ -> Right () + Right _ -> Left "expected invalid document-reference descriptor to fail compilation" + duplicateAId <- parseTestConceptId "decisions/duplicate-a" + duplicateBId <- parseTestConceptId "decisions/duplicate-b" + sourceId <- parseTestConceptId "decisions/source" + assertEqual + [ DanglingHandleReference sourceId (indexedPath 1) "ADR-99", + ReferenceHandlePrefixMismatch sourceId (indexedPath 2) "PAT-3" "ADR", + MalformedDocumentReference sourceId (indexedPath 3) (String "not a reference"), + ExternalReferenceSchemeNotAllowed sourceId (indexedPath 4) "https" ["mori"], + SelfDocumentReference sourceId (indexedPath 6) "ADR-1", + MalformedDocumentReference sourceId (indexedPath 7) (Number 7), + DuplicateDocumentId "ADR-3" duplicateAId duplicateBId + ] + (validateProfile PermissiveConformance compiled concepts) + where + indexedPath elementIndex = FieldPath (FieldName "references" :| [ArrayIndex elementIndex]) + +validateTestProfile :: ProfileSpec -> [Concept] -> [ProfileViolation] +validateTestProfile spec concepts = + case compileProfile spec of + Left errors -> error ("test profile failed to compile: " <> show errors) + Right compiled -> validateProfile PermissiveConformance compiled concepts + +substringIndex :: Text -> Text -> Maybe Int +substringIndex needle haystack = + let (prefix, match) = Text.breakOn needle haystack + in if Text.null match then Nothing else Just (Text.length prefix) + +strictlyIncreasing :: [Int] -> Bool +strictlyIncreasing xs = and (zipWith (<) xs (drop 1 xs)) + +sampleDocument :: Text +sampleDocument = + Text.unlines + [ "---", + "type: BigQuery Table", + "title: Users", + "description: User records.", + "timestamp: 2026-06-16T00:00:00Z", + "tags: [users]", + "---", + "", + "# Schema", + "", + "Body text." + ] + +assertEqual :: (Eq value, Show value) => value -> value -> Either Text () +assertEqual expected actual + | expected == actual = Right () + | otherwise = + Left + ( "expected " + <> Text.pack (show expected) + <> ", got " + <> Text.pack (show actual) + ) + +assertBool :: Text -> Bool -> Either Text () +assertBool _ True = Right () +assertBool label False = Left label + +firstShow :: (Show err) => Either err value -> Either Text value +firstShow = + either (Left . Text.pack . show) Right + +readBundle :: FilePath -> IO [Concept] +readBundle root = do + result <- walkBundle root + case result of + Left bundleError -> fail (show bundleError) + Right concepts -> pure concepts + +-- | Every file the bundle holds, for the path-valued frontmatter check. +readBundleInventory :: FilePath -> IO BundleInventory +readBundleInventory root = do + result <- walkBundleInventory root + case result of + Left bundleError -> fail (show bundleError) + Right inventory -> pure inventory + +-- | 'validateBundle' over a bundle assembled in memory, whose inventory is +-- exactly the concepts' own source paths. Used wherever a test builds concepts +-- rather than walking a directory; a test that does have a root passes +-- 'readBundleInventory' instead, so the non-Markdown files are seen. +validateInMemoryBundle :: ValidationProfile -> VersionDeclaration -> [Concept] -> [BundleValidationError] +validateInMemoryBundle profile declaration concepts = + validateBundle profile declaration (bundleInventoryOfConcepts concepts) concepts fixturePath :: FilePath -> IO FilePath fixturePath name = do diff --git a/test/fixtures/attested-computation/computations/both-computations.md b/test/fixtures/attested-computation/computations/both-computations.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/both-computations.md @@ -0,0 +1,27 @@ +--- +type: Attested Computation +title: Revenue for fiscal year, twice over +description: Names a computation file and also carries one inline. +status: draft +runtime: bigquery +computation: /references/queries/revenue.sql +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Computation + +```sql +SELECT SUM(amount) AS revenue +FROM finance.recognized_revenue +WHERE fiscal_year = @year +``` + +# Notes + +Offers its computation twice: once by the `computation` path, which resolves, +and once as a body block. Specification section 10.3 permits exactly one, and +two leaves a consumer with no way to know which one the producer sanctioned. +The path is not the problem — it names a real file — so the only diagnostic is +the ambiguity. diff --git a/test/fixtures/attested-computation/computations/churn.md b/test/fixtures/attested-computation/computations/churn.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/churn.md @@ -0,0 +1,31 @@ +--- +type: Attested Computation +title: Customer churn for a fiscal year +description: Share of customers active at the start of a year and not at its end. +status: stable +runtime: bigquery +parameters: + - name: year +executor: + resource: /references/skills/run-on-bq.md +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Computation + + SELECT SAFE_DIVIDE(churned, started) AS churn + FROM finance.customer_cohorts + WHERE fiscal_year = @year + +The one concept here that OKF itself has nothing to say about. It declares the +`runtime` specification section 10.2 marks REQUIRED, offers exactly one +computation, and every path-valued field it carries resolves, so both permissive +and strict validation report it not at all. + +It exists for the *profile* layer. Its `parameters` entry carries no `type`, its +`executor` names no `receipt`, and it declares no `attester` — three things the +format permits and a team might not, which is what +`okf-core/test/fixtures/profiles/attested-computation-house.dhall` demonstrates +and `docs/user/profiles.md` documents. diff --git a/test/fixtures/attested-computation/computations/margin.md b/test/fixtures/attested-computation/computations/margin.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/margin.md @@ -0,0 +1,23 @@ +--- +type: Attested Computation +title: Gross margin for fiscal year +description: Gross margin for a fiscal year, as a fraction of revenue. +status: draft +parameters: + - name: year + type: integer + required: true +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Computation + + SELECT SAFE_DIVIDE(gross_profit, revenue) AS margin + FROM finance.income_statement + WHERE fiscal_year = @year + +Declares no `runtime`, which specification section 10.2 marks REQUIRED for this +type. This is the one concept in the bundle strict validation reports, and it +reports nothing in permissive mode. diff --git a/test/fixtures/attested-computation/computations/no-computation.md b/test/fixtures/attested-computation/computations/no-computation.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/no-computation.md @@ -0,0 +1,17 @@ +--- +type: Attested Computation +title: Headcount for fiscal year +description: Headcount at the close of a fiscal year. +status: draft +runtime: bigquery +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Notes + +Declares a contract and then carries no computation: no `computation` path, and +no code block under a `# Computation` heading. Specification section 10.3 +provides the computation in one of two ways, and this concept takes neither, so +strict validation reports it and permissive validation does not. diff --git a/test/fixtures/attested-computation/computations/revenue.md b/test/fixtures/attested-computation/computations/revenue.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/revenue.md @@ -0,0 +1,35 @@ +--- +type: Attested Computation +title: Revenue for fiscal year +description: Recognized revenue for a fiscal year, per Finance's definition. +status: stable +runtime: bigquery +parameters: + - name: year + type: integer + required: true +executor: + resource: /references/skills/run-on-bq.md + receipt: [job_id, executed_sql, result] +attester: + resource: /references/attesters/revenue.py +generated: + by: reference_agent/gemini-2.5-pro + at: 2026-06-20T22:53:05Z +verified: + by: human:ahormati + at: 2026-06-25T09:00:00Z +stale_after: 2026-09-23 +--- + +# Computation + + SELECT SUM(amount) AS revenue + FROM finance.recognized_revenue + WHERE fiscal_year = @year + +The computation binds only the declared `parameters`. Both path-valued contract +fields are written in specification section 6.2's bundle-relative form, with a +leading slash, because a bare `references/...` on a concept under +`computations/` is a relative path and resolves to +`computations/references/...`. diff --git a/test/fixtures/attested-computation/computations/two-blocks.md b/test/fixtures/attested-computation/computations/two-blocks.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/computations/two-blocks.md @@ -0,0 +1,35 @@ +--- +type: Attested Computation +title: Revenue for fiscal year, in two steps +description: Carries two code blocks in one Computation section. +status: draft +runtime: bigquery +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Computation + +```sql +CREATE TEMP TABLE booked AS +SELECT amount, fiscal_year FROM finance.recognized_revenue +``` + +```sql +SELECT SUM(amount) AS revenue FROM booked WHERE fiscal_year = @year +``` + +# Notes + +Two code blocks in one `# Computation` section, where specification section +10.3 says "a single fenced code block". Splitting a computation across blocks +is exactly the shape an attester cannot check, because there is no single +statement to compare against what the executor reports having run. + +The fenced block below is under a later heading of the same level, so the +section that counts ended above it and this is not a third computation: + +```sql +SELECT 1 +``` diff --git a/test/fixtures/attested-computation/index.md b/test/fixtures/attested-computation/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/index.md @@ -0,0 +1,13 @@ +--- +okf_version: "0.2" +--- + +# Attested computation fixture + +- [computations/revenue](computations/revenue.md) +- [computations/margin](computations/margin.md) +- [computations/no-computation](computations/no-computation.md) +- [computations/both-computations](computations/both-computations.md) +- [computations/two-blocks](computations/two-blocks.md) +- [computations/churn](computations/churn.md) +- [metrics/revenue](metrics/revenue.md) diff --git a/test/fixtures/attested-computation/metrics/revenue.md b/test/fixtures/attested-computation/metrics/revenue.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/metrics/revenue.md @@ -0,0 +1,19 @@ +--- +type: Metric +title: Revenue +description: Recognized revenue for a fiscal year. +tags: [finance, revenue] +status: stable +generated: + by: reference_agent/gemini-2.5-pro + at: 2026-06-20T22:53:05Z +--- + +# Definition + +Recognized revenue sums `amount` over rows booked to the fiscal year, computed +by [the revenue computation](/computations/revenue.md). + +This concept carries no contract field at all, and declares no `runtime`. It is +what proves the section 10.2 check touches one `type` and no other: were the +check keyed on anything looser, this concept would be reported too. diff --git a/test/fixtures/attested-computation/references/attesters/revenue.py b/test/fixtures/attested-computation/references/attesters/revenue.py new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/references/attesters/revenue.py @@ -0,0 +1,16 @@ +# Specification section 10.2's own example of an attester resource: deterministic +# code, no language model, that takes a receipt and returns a verdict. okf never +# runs this file. It exists so the fixture proves a non-Markdown target of a +# path-valued contract field resolves against the bundle inventory. + + +def attest(receipt): + """Return whether a run produced its value the sanctioned way.""" + return receipt["executed_sql"].strip() == EXPECTED_SQL.strip() + + +EXPECTED_SQL = """ +SELECT SUM(amount) AS revenue +FROM finance.recognized_revenue +WHERE fiscal_year = @year +""" diff --git a/test/fixtures/attested-computation/references/queries/revenue.sql b/test/fixtures/attested-computation/references/queries/revenue.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/references/queries/revenue.sql @@ -0,0 +1,3 @@ +SELECT SUM(amount) AS revenue +FROM finance.recognized_revenue +WHERE fiscal_year = @year diff --git a/test/fixtures/attested-computation/references/skills/run-on-bq.md b/test/fixtures/attested-computation/references/skills/run-on-bq.md new file mode 100644 --- /dev/null +++ b/test/fixtures/attested-computation/references/skills/run-on-bq.md @@ -0,0 +1,22 @@ +--- +type: Reference +title: Run on BigQuery +description: Run instructions an executor follows to bind and submit a query. +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +--- + +# Run on BigQuery + +Bind the declared parameters, submit the query, and return `job_id`, +`executed_sql`, and `result`. okf never follows these instructions; specification +section 10.5 places the run and its receipt outside the bundle entirely. + +This file carries a `type` because it must. Specification section 11 requires a +non-empty `type` on every non-reserved `.md` file in the tree, with no exemption +for a directory name, so a Markdown file under `references/` is an ordinary +concept. The sibling `references/attesters/revenue.py` is not Markdown and so is +not a concept at all — it is a file the bundle holds, which is exactly what a +path-valued field needs it to be. See +`docs/adr/13-the-references-convention-and-non-markdown-files.md`. diff --git a/test/fixtures/dangling-frontmatter-path/computations/index.md b/test/fixtures/dangling-frontmatter-path/computations/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/computations/index.md @@ -0,0 +1,3 @@ +# Reference + +- [Specification Spelling](spec-spelling.md) - Its resource is the bare references/ path the specification's own example writes. diff --git a/test/fixtures/dangling-frontmatter-path/computations/spec-spelling.md b/test/fixtures/dangling-frontmatter-path/computations/spec-spelling.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/computations/spec-spelling.md @@ -0,0 +1,26 @@ +--- +type: Reference +title: Specification Spelling +description: Its resource is the bare references/ path the specification's own example writes. +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +resource: references/attesters/revenue.py +--- + +# Specification Spelling + +Specification section 10.2's worked example writes +`executor.resource: references/skills/run-on-bq.md` and section 10.4 puts +computations in a `computations/` folder, so a bundle assembled from the +specification's own text names a path nobody wrote. + +Section 6.2 resolution is unchanged and this concept's `resource` really does +name `computations/references/attesters/revenue.py`, which is not here. What the +diagnostic adds is the spelling that would have worked: +`/references/attesters/revenue.py`. + +The sibling `non-markdown.md` writes the same bare text and resolves, because it +sits at the bundle root where the relative and bundle-relative readings are the +same path. That is the whole of the difference, and it is why a concept in a +subdirectory is the only shape that can carry this hint. diff --git a/test/fixtures/dangling-frontmatter-path/dangling.md b/test/fixtures/dangling-frontmatter-path/dangling.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/dangling.md @@ -0,0 +1,14 @@ +--- +type: Reference +title: Dangling +description: Its resource names a bundle file nothing put there. +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +resource: /references/deleted.txt +--- + +# Dangling + +The only concept in this bundle that specification section 6.2 resolution should +report. diff --git a/test/fixtures/dangling-frontmatter-path/external.md b/test/fixtures/dangling-frontmatter-path/external.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/external.md @@ -0,0 +1,13 @@ +--- +type: Reference +title: External +description: Its resource is an absolute URL, which okf never fetches. +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +resource: bigquery://analytics.tables.orders +--- + +# External + +A scheme okf does not know is still a scheme, so this resolves external. diff --git a/test/fixtures/dangling-frontmatter-path/index.md b/test/fixtures/dangling-frontmatter-path/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/index.md @@ -0,0 +1,10 @@ +--- +okf_version: "0.2" +--- + +# Path-valued frontmatter fixture + +- [computations/](computations/index.md) +- [dangling](dangling.md) +- [external](external.md) +- [non-markdown](non-markdown.md) diff --git a/test/fixtures/dangling-frontmatter-path/non-markdown.md b/test/fixtures/dangling-frontmatter-path/non-markdown.md new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/non-markdown.md @@ -0,0 +1,15 @@ +--- +type: Reference +title: Non-Markdown +description: Its resource names a file that is not a concept, and does exist. +generated: + by: human:nadeem + at: 2026-08-01T00:00:00Z +resource: references/attesters/revenue.py +--- + +# Non-Markdown + +Specification section 6.3's own example of what a references/ path points at. +This concept is the one that proves the bundle inventory sees more than +concepts: before it existed, okf could not tell this file from a deleted one. diff --git a/test/fixtures/dangling-frontmatter-path/references/attesters/revenue.py b/test/fixtures/dangling-frontmatter-path/references/attesters/revenue.py new file mode 100644 --- /dev/null +++ b/test/fixtures/dangling-frontmatter-path/references/attesters/revenue.py @@ -0,0 +1,1 @@ +"""A stand-in attester. okf never runs this; it only checks that it is here.""" diff --git a/test/fixtures/profiles/attested-computation-house.dhall b/test/fixtures/profiles/attested-computation-house.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/attested-computation-house.dhall @@ -0,0 +1,131 @@ +-- A *house* profile for the OKF v0.2 attested computation contract +-- (specification §10), and the descriptor `docs/user/profiles.md` documents. +-- +-- Everything here is a house convention rather than a v0.2 rule. §10.2 marks +-- exactly one field REQUIRED for this type, `runtime`, and okf's core already +-- reports a missing one under `--strict`. Demanding that every parameter carry +-- a `type`, or that an executor name a resource the bundle actually holds, is a +-- team's own policy — which is why it lives here and not in +-- `docs/profiles/okf-v0-2.dhall`, whose job is the format's own rules. +-- +-- This file is exercised by `testFrozenFixturesCompile`, so the descriptor +-- `docs/user/profiles.md` shows cannot rot into something that no longer +-- compiles. +-- +-- Two structural points the prose in that document explains, restated where a +-- reader of the descriptor will meet them: +-- +-- * The whole contract is scoped to one `type` with a `TypeRule`. Profile +-- scope would demand `runtime` of every `Metric` in the bundle. +-- * `executor` and `attester` are mappings, so their members are reached with +-- `objectFields`, while `parameters` is a list of mappings, so its members +-- are reached with `elementFields`. Getting that pair the wrong way round is +-- the single easiest mistake to make here. +let Profile = ../../../dhall/Profile.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let NestedRules = ../../../dhall/defaults/NestedRules.dhall + +let Cardinality = ../../../dhall/Cardinality.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +let nested = ../../../dhall/mk/NestedFieldRule.dhall + +-- §10.2. A parameter is a named hole an agent may fill. `name` is what the +-- computation binds; `type` is what this team insists on so an agent knows what +-- kind of value is wanted, and `required` is optional because §10.2 leaves the +-- default to the producer. +let parameterMembers = + NestedRules::{ + , required = + [ nested.documented "name" "The bind name the computation uses." + , nested.documented + "type" + "What kind of value the parameter takes. This team requires one so an agent never has to guess." + // { cardinality = Cardinality.Scalar } + ] + , optional = [ nested.boolean "required" ] + } + +-- §10.2. The executor names the run instructions and the receipt fields a run +-- must return. `bundlePath` checks that the resource names a file the bundle +-- actually holds, which is the whole reason a team writes this rule: a contract +-- whose executor cannot be found is a contract that cannot be honoured. +let executorMembers = + NestedRules::{ + , required = + [ nested.bundlePath "resource" + // { description = Some + "The run instructions, as a path to a file in this bundle." + } + ] + , recommended = + [ nested.list "receipt" + // { description = Some + "The fields a run must return, so an attester knows what to inspect." + } + ] + } + +-- §10.2. The attester is deterministic, no-LLM code that inspects a receipt. +-- Same path policy, same reason. +let attesterMembers = + NestedRules::{ + , required = + [ nested.bundlePath "resource" + // { description = Some + "The attester, as a path to a file in this bundle." + } + ] + } + +in { name = "attested-computation-house" + , description = Some + "A house convention for the OKF v0.2 attested computation contract." + , okfVersion = "0.2" + , frontmatter = + { required = [ field.plain "type" ] + , recommended = [] : List FieldRule.Type + , optional = [] : List FieldRule.Type + } + , allowUnknownTypes = True + , allowUnknownFields = True + , idField = None Text + , requireBundleVersion = None Text + , types = + [ TypeRule::{ + , type = "Attested Computation" + , description = Some + "A sanctioned computation, with the means to check that a value came from running it." + , frontmatter = + { required = + [ field.recordList "parameters" parameterMembers + // { description = Some + "The typed named holes an agent may fill. This team requires at least the declaration, so a computation taking none says so with an empty list." + } + , field.record "executor" executorMembers + // { description = Some + "How a run is performed and what it must return." + } + ] + , recommended = + [ field.record "attester" attesterMembers + // { description = Some + "Deterministic code that inspects a receipt and returns a verdict." + } + ] + , optional = + [ field.bundlePath "computation" + // { description = Some + "The computation, as a path to a file in this bundle, when it is not carried inline." + } + ] + } + } + ] + } + : Profile diff --git a/test/fixtures/profiles/cardinality.dhall b/test/fixtures/profiles/cardinality.dhall --- a/test/fixtures/profiles/cardinality.dhall +++ b/test/fixtures/profiles/cardinality.dhall @@ -22,6 +22,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = None Text + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Cardinality Concept" diff --git a/test/fixtures/profiles/closed-fields.dhall b/test/fixtures/profiles/closed-fields.dhall --- a/test/fixtures/profiles/closed-fields.dhall +++ b/test/fixtures/profiles/closed-fields.dhall @@ -20,6 +20,7 @@ , allowUnknownTypes = False , allowUnknownFields = False , idField = Some "requestId" + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Improvement Request" diff --git a/test/fixtures/profiles/conditional-fields-ep2.dhall b/test/fixtures/profiles/conditional-fields-ep2.dhall --- a/test/fixtures/profiles/conditional-fields-ep2.dhall +++ b/test/fixtures/profiles/conditional-fields-ep2.dhall @@ -3,7 +3,19 @@ -- preserve both top-level and nested `when` values while adding `None`. let Cardinality = ../../../dhall/Cardinality.dhall -let FieldFormat = ../../../dhall/FieldFormat.dhall +-- The format union is written out rather than imported from +-- `../../../dhall/FieldFormat.dhall`. A Dhall union value carries its full +-- alternative set in its type, so importing the live file would give this +-- frozen fixture whatever alternatives that file later gains and would leave +-- it exercising no frozen decoder at all. These are the five alternatives the +-- published union had when this fixture was frozen. +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > let FieldCondition = { field : Text, hasValue : List Text } diff --git a/test/fixtures/profiles/decisions.dhall b/test/fixtures/profiles/decisions.dhall --- a/test/fixtures/profiles/decisions.dhall +++ b/test/fixtures/profiles/decisions.dhall @@ -30,6 +30,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = Some "docId" + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Decision Record" diff --git a/test/fixtures/profiles/document-references-ep3.dhall b/test/fixtures/profiles/document-references-ep3.dhall --- a/test/fixtures/profiles/document-references-ep3.dhall +++ b/test/fixtures/profiles/document-references-ep3.dhall @@ -8,7 +8,19 @@ -- keeps typechecking after the published schema moves on. let Cardinality = ../../../dhall/Cardinality.dhall -let FieldFormat = ../../../dhall/FieldFormat.dhall +-- The format union is written out rather than imported from +-- `../../../dhall/FieldFormat.dhall`. A Dhall union value carries its full +-- alternative set in its type, so importing the live file would give this +-- frozen fixture whatever alternatives that file later gains and would leave +-- it exercising no frozen decoder at all. These are the five alternatives the +-- published union had when this fixture was frozen. +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > let FieldCondition = { field : Text, hasValue : List Text } diff --git a/test/fixtures/profiles/document-references-invalid.dhall b/test/fixtures/profiles/document-references-invalid.dhall --- a/test/fixtures/profiles/document-references-invalid.dhall +++ b/test/fixtures/profiles/document-references-invalid.dhall @@ -42,6 +42,7 @@ , allowUnknownTypes = True , allowUnknownFields = True , idField = Some "docId" + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Decision Record" diff --git a/test/fixtures/profiles/document-references.dhall b/test/fixtures/profiles/document-references.dhall --- a/test/fixtures/profiles/document-references.dhall +++ b/test/fixtures/profiles/document-references.dhall @@ -35,6 +35,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = Some "docId" + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Decision Record" diff --git a/test/fixtures/profiles/formats-ep4.dhall b/test/fixtures/profiles/formats-ep4.dhall --- a/test/fixtures/profiles/formats-ep4.dhall +++ b/test/fixtures/profiles/formats-ep4.dhall @@ -2,7 +2,19 @@ -- descriptor unannotated and unchanged so it exercises the dedicated decoder. let Cardinality = ../../../dhall/Cardinality.dhall -let FieldFormat = ../../../dhall/FieldFormat.dhall +-- The format union is written out rather than imported from +-- `../../../dhall/FieldFormat.dhall`. A Dhall union value carries its full +-- alternative set in its type, so importing the live file would give this +-- frozen fixture whatever alternatives that file later gains and would leave +-- it exercising no frozen decoder at all. These are the five alternatives the +-- published union had when this fixture was frozen. +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > let FieldRule = { field : Text diff --git a/test/fixtures/profiles/formats-mp8-ep2.dhall b/test/fixtures/profiles/formats-mp8-ep2.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/formats-mp8-ep2.dhall @@ -0,0 +1,182 @@ +--| Frozen object-rule descriptor generation from MasterPlan 8 EP-2. +-- This is the published descriptor exactly as it stood immediately before the +-- OKF v0.2 value formats were added to `FieldFormat`: the records match today's +-- shape, `objectFields` and all, and the only difference is the format union, +-- which had exactly the five textual alternatives spelled out below. +-- +-- The union is written out as a literal rather than imported from +-- `../../../dhall/FieldFormat.dhall`, which is the whole point of this fixture: +-- a Dhall union value carries its full alternative set in its type, so a +-- fixture that imports the live schema file acquires whatever alternatives that +-- file gains and exercises no frozen decoder at all. `Cardinality` is likewise +-- written out. Every published type this fixture names is spelled out here. +-- +-- FROZEN: never edit this file. If a test on it fails, the fault is in the +-- decoder chain in `okf-core/src/Okf/Profile.hs`, not here. +let Cardinality = < Any | List | Scalar > + +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > + +let FieldCondition = { field : Text, hasValue : List Text } + +let HandleReferenceRule = + { localPrefix : Text + , externalUriSchemes : List Text + , allowSelf : Bool + } + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , when : Optional FieldCondition + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + , optional : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , objectFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , when : Optional FieldCondition + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : List FieldRule + , optional : List FieldRule + } + +let TypeRule = + { type : Text + , description : Optional Text + , frontmatter : FrontmatterRules + , pathPattern : Optional Text + , resourceScheme : Optional Text + , requireSchemaSection : Bool + , schemaColumns : List Text + , idPrefix : Optional Text + } + +let Profile = + { name : Text + , description : Optional Text + , okfVersion : Text + , frontmatter : FrontmatterRules + , allowUnknownTypes : Bool + , allowUnknownFields : Bool + , idField : Optional Text + , types : List TypeRule + } + +let plain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , elementFields = None NestedRules + , objectFields = None NestedRules + , reference = None HandleReferenceRule + , when = None FieldCondition + } + +let nestedPlain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , when = None FieldCondition + } + +in { name = "formats-mp8-ep2" + , description = None Text + , okfVersion = "0.1" + , frontmatter = + { required = + [ plain "type" + , plain "title" + // { cardinality = Cardinality.Scalar } + , plain "generated" + // { objectFields = Some + { required = + [ nestedPlain "by" + // { cardinality = Cardinality.Scalar } + , nestedPlain "at" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Rfc3339Utc + } + ] + , recommended = [] : List NestedFieldRule + , optional = [] : List NestedFieldRule + } + } + ] + , recommended = + [ plain "timestamp" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Rfc3339Utc + } + , plain "reviewed" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Date + } + ] + , optional = + [ plain "homepage" + // { cardinality = Cardinality.Scalar + , format = Some (FieldFormat.UriWithScheme "https") + } + , plain "supersedes" + // { cardinality = Cardinality.Scalar + , format = Some (FieldFormat.DocumentHandle "ADR") + } + , plain "seeAlso" + // { cardinality = Cardinality.Scalar, format = Some FieldFormat.Uri } + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = None Text + , types = + [ { type = "Decision Record" + , description = None Text + , frontmatter = + { required = + [ plain "decidedOn" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Date + } + ] + , recommended = [] : List FieldRule + , optional = [] : List FieldRule + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] + } + : Profile diff --git a/test/fixtures/profiles/formats.dhall b/test/fixtures/profiles/formats.dhall --- a/test/fixtures/profiles/formats.dhall +++ b/test/fixtures/profiles/formats.dhall @@ -32,6 +32,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = Some "docId" + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Format Concept" diff --git a/test/fixtures/profiles/nested-reviews-ep1.dhall b/test/fixtures/profiles/nested-reviews-ep1.dhall --- a/test/fixtures/profiles/nested-reviews-ep1.dhall +++ b/test/fixtures/profiles/nested-reviews-ep1.dhall @@ -1,6 +1,18 @@ let Cardinality = ../../../dhall/Cardinality.dhall -let FieldFormat = ../../../dhall/FieldFormat.dhall +-- The format union is written out rather than imported from +-- `../../../dhall/FieldFormat.dhall`. A Dhall union value carries its full +-- alternative set in its type, so importing the live file would give this +-- frozen fixture whatever alternatives that file later gains and would leave +-- it exercising no frozen decoder at all. These are the five alternatives the +-- published union had when this fixture was frozen. +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > let NestedFieldRule = { field : Text diff --git a/test/fixtures/profiles/nested-reviews.dhall b/test/fixtures/profiles/nested-reviews.dhall --- a/test/fixtures/profiles/nested-reviews.dhall +++ b/test/fixtures/profiles/nested-reviews.dhall @@ -61,6 +61,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = None Text + , requireBundleVersion = None Text , types = [ TypeRule::{ type = "Reviewed Concept" } ] } : Profile diff --git a/test/fixtures/profiles/object-fields-mp8-ep1.dhall b/test/fixtures/profiles/object-fields-mp8-ep1.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/object-fields-mp8-ep1.dhall @@ -0,0 +1,172 @@ +--| Frozen optional-presence descriptor generation from MasterPlan 8 EP-1. +-- This is the published descriptor exactly as it stood immediately before +-- `objectFields` was added to `FieldRule`: it has the `optional` presence list +-- at both scopes, `reference`, `when`, and one level of `elementFields`, and it +-- deliberately has no `objectFields` member anywhere. The compatibility decoder +-- must preserve every other field while supplying `objectFields = None`. +-- +-- FROZEN: never edit this file. If a test on it fails, the fault is in the +-- decoder chain in `okf-core/src/Okf/Profile.hs`, not here. The file is also +-- deliberately unannotated at the bottom against an imported `Profile` type +-- that is spelled out below rather than imported, precisely so it keeps +-- typechecking after the published schema moves on. +let Cardinality = ../../../dhall/Cardinality.dhall + +-- The format union is written out rather than imported from +-- `../../../dhall/FieldFormat.dhall`. A Dhall union value carries its full +-- alternative set in its type, so importing the live file would give this +-- frozen fixture whatever alternatives that file later gains and would leave +-- it exercising no frozen decoder at all. These are the five alternatives the +-- published union had when this fixture was frozen. +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + > + +let FieldCondition = { field : Text, hasValue : List Text } + +let HandleReferenceRule = + { localPrefix : Text + , externalUriSchemes : List Text + , allowSelf : Bool + } + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , when : Optional FieldCondition + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + , optional : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , when : Optional FieldCondition + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : List FieldRule + , optional : List FieldRule + } + +let TypeRule = + { type : Text + , description : Optional Text + , frontmatter : FrontmatterRules + , pathPattern : Optional Text + , resourceScheme : Optional Text + , requireSchemaSection : Bool + , schemaColumns : List Text + , idPrefix : Optional Text + } + +let Profile = + { name : Text + , description : Optional Text + , okfVersion : Text + , frontmatter : FrontmatterRules + , allowUnknownTypes : Bool + , allowUnknownFields : Bool + , idField : Optional Text + , types : List TypeRule + } + +let plain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , elementFields = None NestedRules + , reference = None HandleReferenceRule + , when = None FieldCondition + } + +let nestedPlain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , when = None FieldCondition + } + +in { name = "object-fields-mp8-ep1" + , description = None Text + , okfVersion = "0.1" + , frontmatter = + { required = [ plain "type", plain "title" ] + , recommended = + [ plain "supersedes" + // { cardinality = Cardinality.Scalar + , reference = Some + { localPrefix = "ADR" + , externalUriSchemes = [ "mori" ] + , allowSelf = False + } + } + , plain "reviews" + // { cardinality = Cardinality.List + , elementFields = Some + { required = + [ nestedPlain "kind" + // { allowedValues = [ "human", "model" ] + , cardinality = Cardinality.Scalar + } + ] + , recommended = [ nestedPlain "notes" ] + , optional = [ nestedPlain "url" ] + } + } + ] + , optional = + [ plain "supersededBy" + // { cardinality = Cardinality.Scalar + , format = Some (FieldFormat.DocumentHandle "ADR") + } + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ { type = "Decision Record" + , description = None Text + , frontmatter = + { required = + [ plain "status" + // { allowedValues = [ "accepted", "superseded" ] + , cardinality = Cardinality.Scalar + } + ] + , recommended = [] : List FieldRule + , optional = [] : List FieldRule + } + , pathPattern = Some "decisions/*" + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = Some "ADR" + } + ] + } + : Profile diff --git a/test/fixtures/profiles/path-references-mp8-ep3.dhall b/test/fixtures/profiles/path-references-mp8-ep3.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/path-references-mp8-ep3.dhall @@ -0,0 +1,198 @@ +--| Frozen descriptor generation from MasterPlan 8 EP-3. +-- This is the published descriptor exactly as it stood immediately before +-- path-valued reference rules were added: today's shape minus the `path` member +-- on `FieldRule` and on `NestedFieldRule`. +-- +-- Every published type this fixture names is written out as a literal rather +-- than imported from `../../../dhall/`. That is the whole point of the fixture: +-- a Dhall union value carries its full alternative set in its type and a record +-- literal carries its full member set, so a fixture that imports a live schema +-- file acquires whatever that file later gains and exercises no frozen decoder +-- at all. `Cardinality` and `FieldFormat` are spelled out for that reason even +-- though this generation changes neither. +-- +-- `FieldFormat` here carries the ten alternatives published when this generation +-- was current, not the five of `formats-mp8-ep2.dhall`: that fixture is frozen +-- one generation earlier and the two must not be confused. +-- +-- FROZEN: never edit this file. If a test on it fails, the fault is in the +-- decoder chain in `okf-core/src/Okf/Profile.hs`, not here. +-- +-- Repaired once, on the day it was written, before any release depended on it: +-- as first committed it declared `okfVersion = "0.1"` while using the v0.2 actor +-- formats, and declared a `reference` rule with no profile `idField` and no type +-- `idPrefix`. Both made it a descriptor that loaded and could never compile, so +-- it was not representative of the pinned descriptor it exists to stand for. No +-- member's presence or absence changed. See +-- `docs/adr/11-growing-the-profile-descriptor-language.md` on why a frozen +-- fixture must compile and not merely decode. +let Cardinality = < Any | List | Scalar > + +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + | Actor + | HumanActor + | Integer + | NonNegativeInteger + | Boolean + > + +let FieldCondition = { field : Text, hasValue : List Text } + +let HandleReferenceRule = + { localPrefix : Text + , externalUriSchemes : List Text + , allowSelf : Bool + } + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , when : Optional FieldCondition + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + , optional : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , objectFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , when : Optional FieldCondition + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : List FieldRule + , optional : List FieldRule + } + +let TypeRule = + { type : Text + , description : Optional Text + , frontmatter : FrontmatterRules + , pathPattern : Optional Text + , resourceScheme : Optional Text + , requireSchemaSection : Bool + , schemaColumns : List Text + , idPrefix : Optional Text + } + +let Profile = + { name : Text + , description : Optional Text + , okfVersion : Text + , frontmatter : FrontmatterRules + , allowUnknownTypes : Bool + , allowUnknownFields : Bool + , idField : Optional Text + , types : List TypeRule + } + +let plain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , elementFields = None NestedRules + , objectFields = None NestedRules + , reference = None HandleReferenceRule + , when = None FieldCondition + } + +let nestedPlain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , when = None FieldCondition + } + +in { name = "path-references-mp8-ep3" + , description = None Text + , okfVersion = "0.2" + , frontmatter = + { required = + [ plain "type" + , plain "sources" + // { cardinality = Cardinality.List + , elementFields = Some + { required = + [ nestedPlain "resource" + // { cardinality = Cardinality.Scalar } + ] + , recommended = [] : List NestedFieldRule + , optional = [] : List NestedFieldRule + } + } + , plain "generated" + // { objectFields = Some + { required = + [ nestedPlain "by" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Actor + } + ] + , recommended = [] : List NestedFieldRule + , optional = [] : List NestedFieldRule + } + } + ] + , recommended = + [ plain "usage_count" + // { format = Some FieldFormat.NonNegativeInteger } + ] + , optional = + [ plain "supersededBy" + // { reference = Some + { localPrefix = "ADR" + , externalUriSchemes = [ "mori" ] + , allowSelf = False + } + } + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ { type = "Metric" + , description = None Text + , frontmatter = + { required = + [ plain "owner" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.HumanActor + } + ] + , recommended = [] : List FieldRule + , optional = [] : List FieldRule + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = Some "ADR" + } + ] + } + : Profile diff --git a/test/fixtures/profiles/postgresql.dhall b/test/fixtures/profiles/postgresql.dhall --- a/test/fixtures/profiles/postgresql.dhall +++ b/test/fixtures/profiles/postgresql.dhall @@ -48,6 +48,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = None Text + , requireBundleVersion = None Text , types = [ { type = "PostgreSQL Schema" , description = Some "One namespace grouping tables and views." diff --git a/test/fixtures/profiles/pre-bundle-version.dhall b/test/fixtures/profiles/pre-bundle-version.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/pre-bundle-version.dhall @@ -0,0 +1,189 @@ +--| Frozen descriptor generation from EP-54. +-- This is the published descriptor exactly as it stood immediately before +-- `requireBundleVersion` was added: today's shape minus that one member on the +-- top-level record. Every other record and every union is identical to today's, +-- which is exactly why this fixture must still spell them all out. +-- +-- Every published type this fixture names is written out as a literal rather +-- than imported from `../../../dhall/`. That is the whole point of the fixture: +-- a Dhall union value carries its full alternative set in its type and a record +-- literal carries its full member set, so a fixture that imports a live schema +-- file acquires whatever that file later gains and exercises no frozen decoder +-- at all. +-- +-- The descriptor is written to compile as well as decode, per +-- `docs/adr/11-growing-the-profile-descriptor-language.md`: `okfVersion = "0.2"` +-- matches the v0.2 formats it uses, and the `reference` rule has both a profile +-- `idField` and a matching type `idPrefix`. +-- +-- FROZEN: never edit this file. If a test on it fails, the fault is in the +-- decoder chain in `okf-core/src/Okf/Profile.hs`, not here. +let Cardinality = < Any | Scalar | List > + +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + | Actor + | HumanActor + | Integer + | NonNegativeInteger + | Boolean + > + +let FieldCondition = { field : Text, hasValue : List Text } + +let HandleReferenceRule = + { localPrefix : Text + , externalUriSchemes : List Text + , allowSelf : Bool + } + +let PathReferenceRule = { externalUriSchemes : List Text, allowSelf : Bool } + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , path : Optional PathReferenceRule + , when : Optional FieldCondition + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + , optional : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , objectFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , path : Optional PathReferenceRule + , when : Optional FieldCondition + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : List FieldRule + , optional : List FieldRule + } + +let TypeRule = + { type : Text + , description : Optional Text + , frontmatter : FrontmatterRules + , pathPattern : Optional Text + , resourceScheme : Optional Text + , requireSchemaSection : Bool + , schemaColumns : List Text + , idPrefix : Optional Text + } + +let Profile = + { name : Text + , description : Optional Text + , okfVersion : Text + , frontmatter : FrontmatterRules + , allowUnknownTypes : Bool + , allowUnknownFields : Bool + , idField : Optional Text + , types : List TypeRule + } + +let plain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , elementFields = None NestedRules + , objectFields = None NestedRules + , reference = None HandleReferenceRule + , path = None PathReferenceRule + , when = None FieldCondition + } + +let nestedPlain = + \(field : Text) -> + { field + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , path = None PathReferenceRule + , when = None FieldCondition + } + +in { name = "pre-bundle-version" + , description = Some "Frozen immediately before requireBundleVersion." + , okfVersion = "0.2" + , frontmatter = + { required = + [ plain "type" + , plain "generated" + // { objectFields = Some + { required = + [ nestedPlain "by" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.Actor + } + ] + , recommended = [] : List NestedFieldRule + , optional = [] : List NestedFieldRule + } + } + ] + , recommended = + [ plain "usage_count" + // { format = Some FieldFormat.NonNegativeInteger } + ] + , optional = + [ plain "supersededBy" + // { reference = Some + { localPrefix = "ADR" + , externalUriSchemes = [ "mori" ] + , allowSelf = False + } + } + , plain "runbook" + // { path = Some + { externalUriSchemes = [ "https" ], allowSelf = False } + } + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ { type = "Metric" + , description = Some "A measured quantity." + , frontmatter = + { required = + [ plain "owner" + // { cardinality = Cardinality.Scalar + , format = Some FieldFormat.HumanActor + } + ] + , recommended = [] : List FieldRule + , optional = [] : List FieldRule + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = Some "ADR" + } + ] + } + : Profile diff --git a/test/fixtures/profiles/type-frontmatter.dhall b/test/fixtures/profiles/type-frontmatter.dhall --- a/test/fixtures/profiles/type-frontmatter.dhall +++ b/test/fixtures/profiles/type-frontmatter.dhall @@ -20,6 +20,7 @@ , allowUnknownTypes = False , allowUnknownFields = True , idField = None Text + , requireBundleVersion = None Text , types = [ TypeRule::{ , type = "Owned Concept" diff --git a/test/fixtures/v01-legacy-bundle/index.md b/test/fixtures/v01-legacy-bundle/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/v01-legacy-bundle/index.md @@ -0,0 +1,10 @@ +# OKF v0.1 legacy fixture bundle + +A deliberately unmigrated bundle. It uses the OKF v0.1 `timestamp` key that +v0.2 supersedes with `generated.at`, and declares no `okf_version`, so it is +exactly the shape every bundle written before v0.2 existed still has. + +It exists to keep the legacy fallback of +`docs/adr/7-okf-v0-1-legacy-fallback-policy.md` under test. Do not migrate it. + +- [tables/](tables/index.md) diff --git a/test/fixtures/v01-legacy-bundle/log.md b/test/fixtures/v01-legacy-bundle/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/v01-legacy-bundle/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-06-16 +* **Update**: Created the v0.1 legacy fixture bundle. diff --git a/test/fixtures/v01-legacy-bundle/tables/index.md b/test/fixtures/v01-legacy-bundle/tables/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/v01-legacy-bundle/tables/index.md @@ -0,0 +1,3 @@ +# BigQuery Table + +- [Orders](orders.md) - Order fact table. diff --git a/test/fixtures/v01-legacy-bundle/tables/orders.md b/test/fixtures/v01-legacy-bundle/tables/orders.md new file mode 100644 --- /dev/null +++ b/test/fixtures/v01-legacy-bundle/tables/orders.md @@ -0,0 +1,15 @@ +--- +type: BigQuery Table +title: Orders +description: Order fact table. +timestamp: 2026-06-16T00:00:00Z +resource: bigquery://analytics.tables.orders +tags: [orders, sales] +--- + +# Orders + +A concept whose only date is the OKF v0.1 `timestamp`. OKF v0.2 supersedes that +key with `generated.at`, and okf reads it anyway: `okf validate --strict` +reports nothing here, because the bundle declares no `okf_version` and an +undeclared bundle is exactly what the fallback exists to serve. diff --git a/test/fixtures/valid-bundle/datasets/sales.md b/test/fixtures/valid-bundle/datasets/sales.md --- a/test/fixtures/valid-bundle/datasets/sales.md +++ b/test/fixtures/valid-bundle/datasets/sales.md @@ -2,7 +2,9 @@ type: Dataset title: Sales Dataset description: Daily sales export used by warehouse tables. -timestamp: 2026-06-16T00:00:00Z +generated: + by: human:nadeem + at: 2026-06-16T00:00:00Z tags: [sales, source] --- diff --git a/test/fixtures/valid-bundle/index.md b/test/fixtures/valid-bundle/index.md --- a/test/fixtures/valid-bundle/index.md +++ b/test/fixtures/valid-bundle/index.md @@ -1,3 +1,7 @@ +--- +okf_version: "0.2" +--- + # OKF fixture bundle - [datasets/](datasets/index.md) diff --git a/test/fixtures/valid-bundle/references/source-system.md b/test/fixtures/valid-bundle/references/source-system.md --- a/test/fixtures/valid-bundle/references/source-system.md +++ b/test/fixtures/valid-bundle/references/source-system.md @@ -2,7 +2,9 @@ type: Reference title: Source System description: External system reference. -timestamp: 2026-06-16T00:00:00Z +generated: + by: human:nadeem + at: 2026-06-16T00:00:00Z --- # Source System diff --git a/test/fixtures/valid-bundle/tables/customers.md b/test/fixtures/valid-bundle/tables/customers.md --- a/test/fixtures/valid-bundle/tables/customers.md +++ b/test/fixtures/valid-bundle/tables/customers.md @@ -2,7 +2,9 @@ type: BigQuery Table title: Customers description: Customer dimension table. -timestamp: 2026-06-16T00:00:00Z +generated: + by: human:nadeem + at: 2026-06-16T00:00:00Z tags: [customers] --- diff --git a/test/fixtures/valid-bundle/tables/orders.md b/test/fixtures/valid-bundle/tables/orders.md --- a/test/fixtures/valid-bundle/tables/orders.md +++ b/test/fixtures/valid-bundle/tables/orders.md @@ -2,7 +2,9 @@ type: BigQuery Table title: Orders description: Order fact table. -timestamp: 2026-06-16T00:00:00Z +generated: + by: human:nadeem + at: 2026-06-16T00:00:00Z resource: bigquery://analytics.tables.orders tags: [orders, sales] ---