diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,131 @@ ## [Unreleased] +## [0.3.0.0] - 2026-07-29 + +### Added + +- Top-level document-reference policies through `HandleReferenceRule`, with a + required local handle prefix, explicit external URI schemes, and configurable + self-reference. Compilation validates and merges policies; bundle validation + builds one valid-owner index and reports dangling, wrong-prefix, malformed, + disallowed-external, and self references with indexed `FieldPath` values. + Duplicate owners count as present and retain the existing duplicate-ID + diagnostic. The complete condition-aware descriptor generation is frozen and + upgrades with `reference = Nothing`. +- Same-scope conditional presence through `FieldCondition` and the defaulted + `when` field on top-level and nested field rules. Compilation rejects empty, + undeclared, non-scalar, open-vocabulary, self-referential, and unreachable + predicates; validation evaluates required and strict-recommended clauses + without cascading from invalid sources. The complete bounded-nested descriptor + shape is frozen as a compatibility decoder and upgrades with no condition. +- Bounded one-level nested record rules through `FieldRule.elementFields`, + non-recursive `NestedRules`/`NestedFieldRule` Dhall and Haskell types, + profile/type compilation, indexed `FieldPath` diagnostics, JSON, constructors, + and validation of nested presence, vocabulary, cardinality, and named formats. + The complete EP-4 descriptor shape is frozen as a compatibility decoder and + upgrades with no nested rule. +- Named `FieldFormat` constraints (`Rfc3339Utc`, `Date`, `Uri`, + `UriWithScheme`, and `DocumentHandle`) on `FieldRule`, including parser-backed + scalar/list validation, parameter checks, profile/type refinement, JSON and + Dhall representations, and `ValueFormatMismatch` diagnostics. The complete + EP-3 schema is frozen as a compatibility decoder whose fields upgrade to no + format constraint. +- `Cardinality` (`Any`, `Scalar`, or `List`) on every `FieldRule`, compiled + profile/type merge checks, shape-aware presence, and + `CardinalityMismatch`. Frozen older descriptors upgrade to `Any`. +- `FieldRule.allowedValues`, `ProfileSpec.allowUnknownFields`, structural + `FieldPath` diagnostics, and compiled validation for textual vocabularies and + closed top-level field names. Older descriptors upgrade to unconstrained, + open defaults. +- `coreFrontmatterFields` and deterministic `frontmatterKeys` in + `Okf.Document`, shared by closed-profile validation. +- Type-aware frontmatter rules: each `TypeRule` now carries its own + `FrontmatterRules`, merged with profile-wide rules for matching concepts. +- `CompiledProfile`, `ProfileDefinitionError`, `compileProfile`, + `compiledProfileSpec`, and `profileFieldDescriptionForType`. Compilation + rejects duplicate type rules and ambiguous field declarations before bundle + validation begins. +- `MissingRecommendedProfileField`, emitted for profile recommendations under + `StrictAuthoring`. +- `Okf.Profile.Registry`, which evaluates a registry reference — a Dhall file, a + directory holding `package.dhall`, or a Dhall expression — and enumerates + every profile it publishes under a dotted export path. Discovery is + structural: each field of the normalized record is tested by decoding it, so + no manifest is needed. Schema records exported as `{ Type, default }` are + skipped, and a reference that is itself a profile reports one root entry. +- `ToJSON` instances for `ProfileSpec`, `FrontmatterRules`, and `TypeRule`. A + type rule's name is emitted under the key `type`, matching the Dhall field + rather than the Haskell field `type_`. +- `FieldRule` — `{ field :: Text, description :: Maybe Text, allowedValues :: [Text], cardinality :: Cardinality }` + — one documented and optionally constrained frontmatter key. +- `profileFieldDescription :: ProfileSpec -> Text -> Maybe Text`, the prose a + profile attaches to a frontmatter key, searching `required` then + `recommended`. +- `decodeProfileExpr :: Expr Src Void -> Maybe ProfileSpec`, which decodes an + already-evaluated Dhall expression under the current schema and each frozen + compatibility generation. `Okf.Profile.Registry` uses it, so older profile + registries still enumerate. +- Published Dhall: `dhall/FieldRule.dhall`, `dhall/defaults/FieldRule.dhall`, + and `dhall/mk/FieldRule.dhall` (constructors `plain`, `documented`, `enum`, + `scalar`, and `list`), all + re-exported from `dhall/package.dhall`, which gains a top-level `mk` record. + +### Changed + +- **Breaking.** `FieldRule` gains + `reference :: Maybe HandleReferenceRule`; `ProfileViolation` gains + `DanglingHandleReference`, `ReferenceHandlePrefixMismatch`, + `MalformedDocumentReference`, `ExternalReferenceSchemeNotAllowed`, and + `SelfDocumentReference`; and `ProfileDefinitionError` gains structured + reference-policy errors. Exhaustive consumers, including Mori, must update + these cases as well as the earlier conditional missing-field patterns before + moving both their `cabal.project` and `flake.nix` okf pins. +- **Breaking.** `FieldRule` and `NestedFieldRule` gain + `when :: Maybe FieldCondition`; missing-field `ProfileViolation` constructors + carry the activating condition; and `ProfileDefinitionError` gains structured + condition errors. Exhaustive consumers, including Mori, must update before + moving their `okf-core` pin. +- **Breaking.** `FieldRule` gains `elementFields :: Maybe NestedRules` and + `ProfileViolation` gains `MissingNestedProfileField`, + `MissingRecommendedNestedProfileField`, and `NestedElementNotRecord`. + `ProfileDefinitionError` gains `ElementFieldsRequireList`. Exhaustive library + consumers, including Mori, must handle the new diagnostics. +- **Breaking.** `FieldRule` gains `format :: Maybe FieldFormat`; + `ProfileDefinitionError` gains `InvalidFormatParameter` and + `ConflictingFieldFormat`; and `ProfileViolation` gains + `ValueFormatMismatch`. Exhaustive consumers, including Mori, must handle the + new constructors. The published Dhall schema adds defaulted + `format : Optional FieldFormat` and exports format constructors. +- `okf-core` now depends on `network-uri >=2.6.4 && <2.7` for absolute RFC 3986 + URI parsing. Hackage marks 2.7.0.0 deprecated; 2.6.4.2 is the newest normal, + upstream-tagged release. +- **Breaking.** `validateProfile` now accepts `ValidationProfile` and an opaque + `CompiledProfile` rather than a raw `ProfileSpec`. Library consumers must call + `compileProfile` once, handle definition errors, and select + `PermissiveConformance` or `StrictAuthoring`. Exhaustive + `ProfileViolation` matches must handle `MissingRecommendedProfileField`. +- **Breaking Dhall schema.** `TypeRule` gained + `frontmatter : FrontmatterRules`. `defaults.TypeRule` supplies empty rules; + direct record literals must add the field. A frozen decoder continues to load + the previous self-documenting shape, and the 0.2.x fallback remains intact. +- Profile-wide frontmatter rules now apply to allowed and disallowed unknown + types. Value constraints merge across profile and type scopes, presence + declarations remain ordered clauses, applicable required clauses precede + strict recommendations, and type-level prose wins when present. +- **Breaking.** `FrontmatterRules`'s `required` and `recommended` are now + `[FieldRule]` rather than `[Text]`, and `ProfileSpec` and `TypeRule` each + gained `description :: Maybe Text`. The published Dhall schema changed to + match. Code that constructs or pattern-matches these records must be updated. +- `loadProfileFile` accepts okf 0.2.x descriptors by falling back to a private + legacy decoder and upgrading the result with every description set to + `Nothing`. When both decoders fail it reports the *current* decoder's error, + since that is the schema an author is writing against. The frozen legacy + shape is kept exercised by `test/fixtures/profiles/legacy-0.2.dhall`, which + must never be updated. +- Descriptions remain documentary, but their lookup now follows the compiled + effective rule for a concept type. + ## [0.2.0.0] - 2026-07-26 ### Added diff --git a/dhall/Cardinality.dhall b/dhall/Cardinality.dhall new file mode 100644 --- /dev/null +++ b/dhall/Cardinality.dhall @@ -0,0 +1,5 @@ +--| Cardinality constraint for one profile field. +-- +-- `Any` preserves the legacy presence behavior. `Scalar` accepts text, numbers, +-- and booleans. `List` accepts arrays. +< Any | Scalar | List > diff --git a/dhall/FieldCondition.dhall b/dhall/FieldCondition.dhall new file mode 100644 --- /dev/null +++ b/dhall/FieldCondition.dhall @@ -0,0 +1,5 @@ +--| A same-scope predicate controlling whether a field presence rule applies. +-- +-- `field` names a sibling in the same top-level or nested object. `hasValue` +-- lists the closed scalar textual values that activate the presence rule. +{ field : Text, hasValue : List Text } diff --git a/dhall/FieldFormat.dhall b/dhall/FieldFormat.dhall new file mode 100644 --- /dev/null +++ b/dhall/FieldFormat.dhall @@ -0,0 +1,7 @@ +--| Named textual formats available to profile field rules. +< Rfc3339Utc +| Date +| Uri +| UriWithScheme : Text +| DocumentHandle : Text +> diff --git a/dhall/FieldRule.dhall b/dhall/FieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/FieldRule.dhall @@ -0,0 +1,29 @@ +--| Canonical schema for one documented frontmatter key in an OKF profile. +-- +-- Mirrors the `FieldRule` decoder in `okf-core/src/Okf/Profile.hs`. +-- +-- `description` is documentation for humans and tooling: it is never checked +-- against a bundle and can never produce a profile violation. It exists so a +-- profile can explain what a key is for at the point the key is declared. +-- `allowedValues = []` leaves textual values unconstrained. +-- `cardinality = Cardinality.Any` preserves the legacy scalar-or-list presence +-- behavior. +let Cardinality = ./Cardinality.dhall + +let FieldFormat = ./FieldFormat.dhall + +let NestedRules = ./NestedRules.dhall + +let FieldCondition = ./FieldCondition.dhall + +let HandleReferenceRule = ./HandleReferenceRule.dhall + +in { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , when : Optional FieldCondition + } diff --git a/dhall/FrontmatterRules.dhall b/dhall/FrontmatterRules.dhall --- a/dhall/FrontmatterRules.dhall +++ b/dhall/FrontmatterRules.dhall @@ -1,6 +1,10 @@ --| Canonical schema for a profile's frontmatter expectations. -- -- Mirrors the `FrontmatterRules` decoder in `okf-core/src/Okf/Profile.hs`. -{ required : List Text -, recommended : List Text -} +-- +-- Each entry is a `FieldRule`: the frontmatter key, plus an optional description +-- explaining what the key is for. The description is documentary only — it is +-- never checked against a bundle and can never produce a profile violation. +let FieldRule = ./FieldRule.dhall + +in { required : List FieldRule, recommended : List FieldRule } diff --git a/dhall/HandleReferenceRule.dhall b/dhall/HandleReferenceRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/HandleReferenceRule.dhall @@ -0,0 +1,7 @@ +--| Policy for a top-level field containing local document handles or explicit +-- external URI alternatives. okf resolves only the local handle and never +-- performs network or registry lookups for an external URI. +{ localPrefix : Text +, externalUriSchemes : List Text +, allowSelf : Bool +} diff --git a/dhall/NestedFieldRule.dhall b/dhall/NestedFieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/NestedFieldRule.dhall @@ -0,0 +1,17 @@ +--| Canonical schema for one field inside a list element record. +-- +-- This deliberately omits `elementFields`, so profile schemas are bounded to +-- one list of flat records rather than recursively nested objects. +let Cardinality = ./Cardinality.dhall + +let FieldFormat = ./FieldFormat.dhall + +let FieldCondition = ./FieldCondition.dhall + +in { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , when : Optional FieldCondition + } diff --git a/dhall/NestedRules.dhall b/dhall/NestedRules.dhall new file mode 100644 --- /dev/null +++ b/dhall/NestedRules.dhall @@ -0,0 +1,6 @@ +--| Required and recommended fields inside each record of a list-valued field. +let NestedFieldRule = ./NestedFieldRule.dhall + +in { required : List NestedFieldRule + , recommended : List NestedFieldRule + } diff --git a/dhall/Profile.dhall b/dhall/Profile.dhall --- a/dhall/Profile.dhall +++ b/dhall/Profile.dhall @@ -11,14 +11,21 @@ -- -- `idField = Some "docId"` names the frontmatter key that holds stable document -- handles. `None Text` disables every document-ID check. +-- +-- `description` documents the profile as a whole, in prose, for whoever has to +-- 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. let TypeRule = ./TypeRule.dhall let FrontmatterRules = ./FrontmatterRules.dhall in { name : Text + , description : Optional Text , okfVersion : Text , frontmatter : FrontmatterRules , allowUnknownTypes : Bool + , allowUnknownFields : Bool , idField : Optional Text , types : List TypeRule } diff --git a/dhall/TypeRule.dhall b/dhall/TypeRule.dhall --- a/dhall/TypeRule.dhall +++ b/dhall/TypeRule.dhall @@ -8,7 +8,15 @@ -- -- `idPrefix = Some "ADR"` means concepts governed by this rule are expected to -- carry a handle of the form `ADR-` in the profile's ID field. +-- +-- `description` explains, in prose, what this concept type is for. It is +-- documentary only and is never checked against a bundle. +let FrontmatterRules = ./FrontmatterRules.dhall + +in { type : Text +, description : Optional Text +, frontmatter : FrontmatterRules , pathPattern : Optional Text , resourceScheme : Optional Text , requireSchemaSection : Bool diff --git a/dhall/defaults/FieldRule.dhall b/dhall/defaults/FieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/defaults/FieldRule.dhall @@ -0,0 +1,24 @@ +--| Record-completion defaults for one documented frontmatter key. +let FieldRuleType = ../FieldRule.dhall + +let Cardinality = ../Cardinality.dhall + +let FieldFormat = ../FieldFormat.dhall + +let NestedRules = ../NestedRules.dhall + +let FieldCondition = ../FieldCondition.dhall + +let HandleReferenceRule = ../HandleReferenceRule.dhall + +in { Type = FieldRuleType + , default = + { description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , elementFields = None NestedRules + , reference = None HandleReferenceRule + , when = None FieldCondition + } + } diff --git a/dhall/defaults/FrontmatterRules.dhall b/dhall/defaults/FrontmatterRules.dhall --- a/dhall/defaults/FrontmatterRules.dhall +++ b/dhall/defaults/FrontmatterRules.dhall @@ -1,6 +1,9 @@ --| Record-completion defaults for profile frontmatter expectations. let FrontmatterRulesType = ../FrontmatterRules.dhall +let FieldRule = ../FieldRule.dhall + in { Type = FrontmatterRulesType - , default = { required = [] : List Text, recommended = [] : List Text } + , default = + { required = [] : List FieldRule, recommended = [] : List FieldRule } } diff --git a/dhall/defaults/HandleReferenceRule.dhall b/dhall/defaults/HandleReferenceRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/defaults/HandleReferenceRule.dhall @@ -0,0 +1,9 @@ +--| Record-completion defaults for a document-reference policy. +let HandleReferenceRule = ../HandleReferenceRule.dhall + +in { Type = HandleReferenceRule + , default = + { externalUriSchemes = [] : List Text + , allowSelf = False + } + } diff --git a/dhall/defaults/NestedFieldRule.dhall b/dhall/defaults/NestedFieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/defaults/NestedFieldRule.dhall @@ -0,0 +1,18 @@ +--| Record-completion defaults for one nested field rule. +let NestedFieldRuleType = ../NestedFieldRule.dhall + +let Cardinality = ../Cardinality.dhall + +let FieldFormat = ../FieldFormat.dhall + +let FieldCondition = ../FieldCondition.dhall + +in { Type = NestedFieldRuleType + , default = + { description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + , when = None FieldCondition + } + } diff --git a/dhall/defaults/NestedRules.dhall b/dhall/defaults/NestedRules.dhall new file mode 100644 --- /dev/null +++ b/dhall/defaults/NestedRules.dhall @@ -0,0 +1,11 @@ +--| Record-completion defaults for nested required and recommended fields. +let NestedRulesType = ../NestedRules.dhall + +let NestedFieldRule = ../NestedFieldRule.dhall + +in { Type = NestedRulesType + , default = + { required = [] : List NestedFieldRule + , recommended = [] : List NestedFieldRule + } + } diff --git a/dhall/defaults/Profile.dhall b/dhall/defaults/Profile.dhall --- a/dhall/defaults/Profile.dhall +++ b/dhall/defaults/Profile.dhall @@ -7,9 +7,11 @@ in { Type = ProfileType , default = - { okfVersion = "0.1" + { description = None Text + , okfVersion = "0.1" , frontmatter = FrontmatterRules.default , allowUnknownTypes = True + , allowUnknownFields = True , idField = None Text , types = [] : List TypeRule } diff --git a/dhall/defaults/TypeRule.dhall b/dhall/defaults/TypeRule.dhall --- a/dhall/defaults/TypeRule.dhall +++ b/dhall/defaults/TypeRule.dhall @@ -1,9 +1,13 @@ --| Record-completion defaults for one per-`type` profile rule. let TypeRuleType = ../TypeRule.dhall +let FrontmatterRules = ./FrontmatterRules.dhall + in { Type = TypeRuleType , default = - { pathPattern = None Text + { description = None Text + , frontmatter = FrontmatterRules.default + , pathPattern = None Text , resourceScheme = None Text , requireSchemaSection = False , schemaColumns = [] : List Text diff --git a/dhall/mk/FieldRule.dhall b/dhall/mk/FieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/mk/FieldRule.dhall @@ -0,0 +1,82 @@ +--| Constructors for one documented frontmatter key. +-- +-- `FieldRule` is the profile type authors write most often, usually several times +-- inside one list literal, so it ships constructors as well as the record-completion +-- module in `../defaults/FieldRule.dhall`: +-- +-- let field = okf.mk.FieldRule +-- in [ field.documented "type" "The OKF concept type." , field.plain "title" ] +-- +-- Both are built on record completion, so a future field added to `FieldRule` with a +-- default in `../defaults/FieldRule.dhall` leaves every call site working unchanged. +-- This protects descriptors written from now on; it does nothing for descriptors that +-- already exist, which keep loading via the legacy fallback decoder in +-- `okf-core/src/Okf/Profile.hs`. +let FieldRule = ../defaults/FieldRule.dhall + +let Cardinality = ../Cardinality.dhall + +let FieldFormat = ../FieldFormat.dhall + +let NestedRules = ../NestedRules.dhall + +let FieldCondition = ../FieldCondition.dhall + +let HandleReferenceRule = ../defaults/HandleReferenceRule.dhall + +in { plain = \(field : Text) -> FieldRule::{ field } + , documented = + \(field : Text) -> + \(description : Text) -> + FieldRule::{ field, description = Some description } + , enum = + \(field : Text) -> + \(allowedValues : List Text) -> + FieldRule::{ field, allowedValues } + , scalar = + \(field : Text) -> FieldRule::{ field, cardinality = Cardinality.Scalar } + , list = + \(field : Text) -> FieldRule::{ field, cardinality = Cardinality.List } + , rfc3339Utc = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Rfc3339Utc } + , date = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Date } + , uri = + \(field : Text) -> FieldRule::{ field, format = Some FieldFormat.Uri } + , uriWithScheme = + \(field : Text) -> + \(scheme : Text) -> + FieldRule::{ field, format = Some (FieldFormat.UriWithScheme scheme) } + , documentHandle = + \(field : Text) -> + \(prefix : Text) -> + FieldRule::{ field, format = Some (FieldFormat.DocumentHandle prefix) } + , recordList = + \(field : Text) -> + \(elementFields : NestedRules) -> + FieldRule::{ + , field + , cardinality = Cardinality.List + , elementFields = Some elementFields + } + , conditional = + \(rule : FieldRule.Type) -> + \(condition : FieldCondition) -> + rule with when = Some condition + , localReference = + \(field : Text) -> + \(localPrefix : Text) -> + FieldRule::{ + , field + , reference = Some HandleReferenceRule::{ localPrefix } + } + , localOrExternalReference = + \(field : Text) -> + \(localPrefix : Text) -> + \(externalUriSchemes : List Text) -> + FieldRule::{ + , field + , reference = + Some HandleReferenceRule::{ localPrefix, externalUriSchemes } + } + } diff --git a/dhall/mk/NestedFieldRule.dhall b/dhall/mk/NestedFieldRule.dhall new file mode 100644 --- /dev/null +++ b/dhall/mk/NestedFieldRule.dhall @@ -0,0 +1,41 @@ +--| Constructors for one field inside a list element record. +let NestedFieldRule = ../defaults/NestedFieldRule.dhall + +let Cardinality = ../Cardinality.dhall + +let FieldFormat = ../FieldFormat.dhall + +let FieldCondition = ../FieldCondition.dhall + +in { plain = \(field : Text) -> NestedFieldRule::{ field } + , documented = + \(field : Text) -> + \(description : Text) -> + NestedFieldRule::{ field, description = Some description } + , enum = + \(field : Text) -> + \(allowedValues : List Text) -> + NestedFieldRule::{ field, allowedValues } + , scalar = + \(field : Text) -> NestedFieldRule::{ field, cardinality = Cardinality.Scalar } + , list = + \(field : Text) -> NestedFieldRule::{ field, cardinality = Cardinality.List } + , rfc3339Utc = + \(field : Text) -> NestedFieldRule::{ field, format = Some FieldFormat.Rfc3339Utc } + , date = + \(field : Text) -> NestedFieldRule::{ field, format = Some FieldFormat.Date } + , uri = + \(field : Text) -> NestedFieldRule::{ field, format = Some FieldFormat.Uri } + , uriWithScheme = + \(field : Text) -> + \(scheme : Text) -> + NestedFieldRule::{ field, format = Some (FieldFormat.UriWithScheme scheme) } + , documentHandle = + \(field : Text) -> + \(prefix : Text) -> + NestedFieldRule::{ field, format = Some (FieldFormat.DocumentHandle prefix) } + , conditional = + \(rule : NestedFieldRule.Type) -> + \(condition : FieldCondition) -> + rule with when = Some condition + } diff --git a/dhall/package.dhall b/dhall/package.dhall --- a/dhall/package.dhall +++ b/dhall/package.dhall @@ -8,12 +8,32 @@ -- -- okf itself imports nothing remote; the relationship with okf-profiles is one-way -- (okf-profiles imports this). +-- `defaults` holds the `{ Type, default }` record-completion modules; `mk` holds +-- constructor functions for the types authors write repeatedly. Both protect a +-- descriptor written from now on against future additive, defaulted schema +-- fields; neither is a compatibility mechanism for descriptors that already +-- exist (okf-core's legacy fallback decoder is what keeps those loading). { Profile = ./Profile.dhall , TypeRule = ./TypeRule.dhall , FrontmatterRules = ./FrontmatterRules.dhall +, FieldRule = ./FieldRule.dhall +, FieldCondition = ./FieldCondition.dhall +, HandleReferenceRule = ./HandleReferenceRule.dhall +, NestedRules = ./NestedRules.dhall +, NestedFieldRule = ./NestedFieldRule.dhall +, Cardinality = ./Cardinality.dhall +, FieldFormat = ./FieldFormat.dhall , defaults = { Profile = ./defaults/Profile.dhall , TypeRule = ./defaults/TypeRule.dhall , FrontmatterRules = ./defaults/FrontmatterRules.dhall + , FieldRule = ./defaults/FieldRule.dhall + , HandleReferenceRule = ./defaults/HandleReferenceRule.dhall + , NestedRules = ./defaults/NestedRules.dhall + , NestedFieldRule = ./defaults/NestedFieldRule.dhall + } +, mk = + { FieldRule = ./mk/FieldRule.dhall + , NestedFieldRule = ./mk/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.2.0.0 +version: 0.3.0.0 synopsis: Read, validate, index, and traverse Open Knowledge Format bundles @@ -54,25 +54,27 @@ Okf.Log Okf.Prelude Okf.Profile + Okf.Profile.Registry Okf.Validation build-depends: - , aeson >=2.2 && <2.4 - , attoparsec >=0.14 && <0.15 - , base >=4.20 && <5 - , bytestring >=0.11 && <0.13 + , aeson >=2.2 && <2.4 + , attoparsec >=0.14 && <0.15 + , base >=4.20 && <5 + , bytestring >=0.11 && <0.13 , cmark-gfm ^>=0.2 - , containers >=0.6 && <0.8 - , dhall >=1.41 && <1.43 - , directory >=1.3 && <1.4 - , filepath >=1.4 && <1.6 - , frontmatter >=0.1 && <0.2 - , generic-lens >=2.2 && <2.4 + , containers >=0.6 && <0.8 + , dhall >=1.41 && <1.43 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , frontmatter >=0.1 && <0.2 + , generic-lens >=2.2 && <2.4 , lens ^>=5.3 + , network-uri >=2.6.4 && <2.7 , text ^>=2.1 - , time >=1.12 && <1.15 - , vector >=0.13 && <0.14 - , yaml >=0.11 && <0.12 + , time >=1.12 && <1.15 + , vector >=0.13 && <0.14 + , yaml >=0.11 && <0.12 test-suite okf-core-test import: common-options diff --git a/src/Okf/Document.hs b/src/Okf/Document.hs --- a/src/Okf/Document.hs +++ b/src/Okf/Document.hs @@ -5,6 +5,8 @@ DocumentParseError (..), emptyFrontmatter, frontmatterLookup, + frontmatterKeys, + coreFrontmatterFields, parseDocument, serializeDocument, @@ -28,7 +30,10 @@ import Data.Attoparsec.ByteString qualified as Attoparsec import Data.ByteString qualified as ByteString import Data.Frontmatter qualified as Frontmatter +import Data.List qualified as List import Data.Ord (comparing) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text.Encoding import Data.Vector qualified as Vector @@ -65,6 +70,19 @@ frontmatterLookup key (Frontmatter rawFields) = KeyMap.lookup (AesonKey.fromText key) rawFields +-- | All top-level frontmatter keys in lexical order. Aeson's 'KeyMap.keys' +-- order depends on its backing representation, so callers must not expose it +-- directly when deterministic diagnostics matter. +frontmatterKeys :: Frontmatter -> [Text] +frontmatterKeys (Frontmatter rawFields) = + List.sort (map AesonKey.toText (KeyMap.keys rawFields)) + +-- | Frontmatter keys understood directly by OKF parsing, validation, and +-- authoring. Closed profiles always permit these keys even when they are not +-- repeated as profile field rules. +coreFrontmatterFields :: Set Text +coreFrontmatterFields = Set.fromList coreFrontmatterFieldOrder + -- | Build frontmatter from a list of @(key, value)@ pairs. Later duplicate -- keys overwrite earlier ones. frontmatterFromFields :: [(Text, Value)] -> Frontmatter @@ -166,8 +184,10 @@ Just rank -> (rank, "") Nothing -> (length commonRanks, keyText) where - commonRanks = - zip ["type", "title", "description", "timestamp", "resource", "tags"] [0 ..] + commonRanks = zip coreFrontmatterFieldOrder [0 ..] + +coreFrontmatterFieldOrder :: [Text] +coreFrontmatterFieldOrder = ["type", "title", "description", "timestamp", "resource", "tags"] parseFrontmatterDocument :: ByteString.ByteString -> Either DocumentParseError OKFDocument parseFrontmatterDocument inputBytes = diff --git a/src/Okf/Profile.hs b/src/Okf/Profile.hs --- a/src/Okf/Profile.hs +++ b/src/Okf/Profile.hs @@ -13,289 +13,2209 @@ ( -- * Descriptor ProfileSpec (..), FrontmatterRules (..), - TypeRule (..), - loadProfileFile, - - -- * Validation - DocumentId (..), - parseDocumentId, - renderDocumentId, - documentIdsInBundle, - nextDocumentId, - ProfileViolation (..), - validateProfile, - - -- * Body inspection - schemaSectionColumns, - ) -where - -import CMarkGFM qualified -import Control.Exception (SomeException, catch) -import Data.Char (isAsciiLower, isAsciiUpper) -import Data.List qualified as List -import Data.Text qualified as Text -import Data.Text.Read qualified as Text.Read -import Dhall (FromDhall (..), auto, genericAutoWith) -import Dhall qualified -import Numeric.Natural (Natural) -import Okf.Bundle - ( Concept, - conceptDocument, - conceptIdOf, - conceptResource, - conceptType, - ) -import Okf.ConceptId (ConceptId, renderConceptId) -import Okf.Document (Frontmatter, frontmatterLookup) -import Okf.Prelude -import "generic-lens" Data.Generics.Labels () - --- | A complete house profile. -data ProfileSpec = ProfileSpec - { name :: !Text, - okfVersion :: !Text, - frontmatter :: !FrontmatterRules, - allowUnknownTypes :: !Bool, - idField :: !(Maybe Text), - types :: ![TypeRule] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | Frontmatter keys the profile expects on every concept. -data FrontmatterRules = FrontmatterRules - { required :: ![Text], - recommended :: ![Text] - } - deriving stock (Generic, Eq, Show) - deriving anyclass (FromDhall) - --- | One rule per allowed concept @type@ string. -data TypeRule = TypeRule - { type_ :: !Text, - 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) - --- | Load and decode a Dhall profile descriptor from a file path. Any evaluation --- or decoding failure is captured as a human-readable 'Left'. -loadProfileFile :: FilePath -> IO (Either Text ProfileSpec) -loadProfileFile path = - (Right <$> Dhall.inputFile auto path) - `catch` \(e :: SomeException) -> pure (Left (Text.pack (show e))) - --- | 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 - isAsciiLetter character = - isAsciiLower character || isAsciiUpper character - 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 - ] - --- | 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) - MissingProfileField ConceptId Text - | -- | 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 the profile, returning all deviations. Concepts --- whose @type@ is not in the profile vocabulary skip the per-rule checks (there --- is no rule to check against) and only produce a 'TypeNotInProfile' violation --- when @allowUnknownTypes@ is @False@. -validateProfile :: ProfileSpec -> [Concept] -> [ProfileViolation] -validateProfile spec concepts = - concatMap checkConcept concepts <> checkDuplicateDocumentIds spec concepts - where - rulesByType = [(rule ^. #type_, rule) | rule <- spec ^. #types] - - checkConcept concept = - let cid = conceptIdOf concept - ctype = conceptType concept - in case lookup ctype rulesByType of - Nothing -> - [TypeNotInProfile cid ctype | not (spec ^. #allowUnknownTypes)] - Just rule -> - checkRequiredFields cid concept - <> checkPath cid ctype rule - <> checkResource cid ctype rule concept - <> checkSchema cid ctype rule concept - <> checkDocumentId spec cid ctype rule concept - - checkRequiredFields cid concept = - [ MissingProfileField cid key - | key <- spec ^. #frontmatter . #required, - not (hasNonEmptyField key (conceptFrontmatter concept)) - ] - --- | 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 field counts as present only if it is a non-empty string or a non-empty --- list (mirroring how the core validator treats @type@). Anything else, --- including a missing key, does not count. -hasNonEmptyField :: Text -> Frontmatter -> Bool -hasNonEmptyField key fm = - case frontmatterLookup key fm of - Just (String value) -> not (Text.null (Text.strip value)) - Just (Array values) -> not (null values) - _ -> False + 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. +data FrontmatterRules = FrontmatterRules + { required :: ![FieldRule], + recommended :: ![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] + } + 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} = + object + [ "required" .= required, + "recommended" .= recommended + ] + +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} = + object + [ "required" .= required, + "recommended" .= recommended + ] + +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 condition-aware descriptor generation, frozen before +-- top-level document-reference policies were added. This is the immediately +-- preceding public descriptor generation. +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 = []} + +upgradePreviousFrontmatter :: PreviousFrontmatterRules -> FrontmatterRules +upgradePreviousFrontmatter previous = + FrontmatterRules + { required = map upgradeField (previous ^. #required), + recommended = map upgradeField (previous ^. #recommended) + } + 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) + } + 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) + } + 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) + } + 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) + } + 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) + } + 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) + } + 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) + } + where + upgradeField rule = + FieldRule + { field = rule ^. #field, + description = rule ^. #description, + allowedValues = rule ^. #allowedValues, + cardinality = Any, + format = Nothing, + elementFields = Nothing, + reference = Nothing, + when = Nothing + } + +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) + }, + 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 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 + 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 nine 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 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 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 and then @recommended@. '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 + +-- | A malformed profile definition. The optional type is absent for profile +-- scope and present for a type-specific scope. The list name is @required@ or +-- @recommended@. +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 + 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)) + + 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} = + [DuplicateFieldRule scope "required" key | key <- duplicates (map (^. #field) required)] + <> [DuplicateFieldRule scope "recommended" key | key <- duplicates (map (^. #field) recommended)] + <> [ ConflictingFieldRequirement scope key + | key <- List.nub (List.sort (List.intersect (map (^. #field) required) (map (^. #field) recommended))) + ] + <> concatMap (nestedScopeErrors scope) (required <> recommended) + + nestedScopeErrors scope parentRule = + case parentRule ^. #elementFields of + Nothing -> [] + Just NestedRules {required, recommended} -> + 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)] + <> [ ConflictingFieldRequirement scope (qualify key) + | key <- List.nub (List.sort (List.intersect (map (^. #field) required) (map (^. #field) recommended))) + ] + + 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, + 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, + 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, + Just nestedRules <- [rule ^. #elementFields], + nestedRule <- nestedRules ^. #required <> nestedRules ^. #recommended, + 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) + <> 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) + _ -> [] + | rawRule <- rules ^. #required <> rules ^. #recommended + ] + + 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) + + 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} = + Map.fromList + ( [ (rule ^. #field, compileFieldRule RequiredField rule) + | rule <- required + ] + <> [ (rule ^. #field, compileFieldRule RecommendedField rule) + | rule <- recommended + ] + ) + +compileFieldRule :: FieldRequirement -> FieldRule -> EffectiveFieldRule +compileFieldRule requirement rule = + EffectiveFieldRule + { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)], + 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 + } + +compileNestedRules :: NestedRules -> Map Text EffectiveFieldRule +compileNestedRules NestedRules {required, recommended} = + Map.fromList + ( [ (rule ^. #field, compileNestedFieldRule RequiredField rule) + | rule <- required + ] + <> [ (rule ^. #field, compileNestedFieldRule RecommendedField rule) + | rule <- recommended + ] + ) + +compileNestedFieldRule :: FieldRequirement -> NestedFieldRule -> EffectiveFieldRule +compileNestedFieldRule requirement rule = + EffectiveFieldRule + { presenceClauses = [PresenceClause requirement (compileCondition <$> rule ^. #when)], + description = rule ^. #description, + allowedValues = deduplicate (rule ^. #allowedValues), + cardinality = rule ^. #cardinality, + format = rule ^. #format, + elementFields = Nothing, + reference = Nothing + } + +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. diff --git a/src/Okf/Profile/Registry.hs b/src/Okf/Profile/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Profile/Registry.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE PackageImports #-} + +-- | Profile registries: discovery of the profiles a Dhall package publishes. +-- +-- A /registry/ is nothing more than a Dhall expression that evaluates to a +-- record whose fields (possibly nested) are profile values. There is no +-- manifest and no metadata format; profiles are found structurally, by walking +-- the normalized record and asking of each field \"does this value decode as a +-- 'ProfileSpec'?\". +-- +-- The published @okf-profiles@ package is already exactly this shape, so +-- 'loadRegistry' works against it unchanged. +module Okf.Profile.Registry + ( -- * References + RegistryRef (..), + defaultRegistryReference, + resolveRegistryRef, + renderRegistryRef, + + -- * Enumeration + RegistryEntry (..), + loadRegistry, + registryEntries, + findRegistryEntry, + rootExportLabel, + ) +where + +import Control.Exception (SomeException, catch) +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Void (Void) +import Dhall qualified +import Dhall.Core (Expr (RecordLit), recordFieldValue) +import Dhall.Map qualified +import Dhall.Src (Src) +import Okf.Prelude +import Okf.Profile (ProfileSpec, decodeProfileExpr) +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (takeDirectory, ()) +import "generic-lens" Data.Generics.Labels () + +-- | How a registry reference is to be evaluated. A file must be evaluated with +-- its own directory as the import root, or its relative imports (such as +-- @./profiles/postgresql.dhall@) will not resolve. +data RegistryRef + = -- | a Dhall file on disk + RegistryFile !FilePath + | -- | a raw Dhall expression, such as a hash-pinned URL + RegistryExpression !Text + deriving stock (Generic, Eq, Show) + +-- | One profile published by a registry, under the dotted field path at which +-- it was found. The export path is empty when the registry reference is itself +-- a profile; 'rootExportLabel' is the display form for that case. +data RegistryEntry = RegistryEntry + { export :: !Text, + spec :: !ProfileSpec + } + deriving stock (Generic, Eq, Show) + +-- | The built-in registry: the @okf-profiles@ package, pinned by tag /and/ +-- integrity hash. Pinning gives Dhall's content-addressed cache something +-- stable to key on, so listing costs one network fetch ever, and a later +-- @okf-profiles@ release cannot silently change what okf reports. Moving to a +-- newer tag means changing the URL and the hash together. +defaultRegistryReference :: Text +defaultRegistryReference = + "https://raw.githubusercontent.com/shinzui/okf-profiles/v0.4.2/package.dhall\ + \ sha256:39e79b65672439cde9c1271e3d92abf68ba1e2427541598e0d04de23e741f0cb" + +-- | How an entry with an empty export path is displayed. +rootExportLabel :: Text +rootExportLabel = "(root)" + +-- | Decide how to evaluate a registry reference: an existing file is evaluated +-- as a file, an existing directory holding @package.dhall@ resolves to that +-- file, and anything else is handed to Dhall verbatim as an expression. Only +-- the last case can reach the network, and only if the expression says so. +resolveRegistryRef :: Text -> IO RegistryRef +resolveRegistryRef reference = do + let path = Text.unpack (Text.strip reference) + isFile <- doesFileExist path + if isFile + then pure (RegistryFile path) + else do + isDirectory <- doesDirectoryExist path + if isDirectory + then do + let packagePath = path "package.dhall" + hasPackage <- doesFileExist packagePath + pure + ( if hasPackage + then RegistryFile packagePath + else RegistryExpression reference + ) + else pure (RegistryExpression reference) + +-- | Render a reference for display in messages. +renderRegistryRef :: RegistryRef -> Text +renderRegistryRef (RegistryFile path) = Text.pack path +renderRegistryRef (RegistryExpression expression) = expression + +-- | Evaluate a registry and enumerate the profiles it publishes. Any parse, +-- import, type, or IO failure is captured as a human-readable 'Left', matching +-- how 'Okf.Profile.loadProfileFile' behaves. +loadRegistry :: RegistryRef -> IO (Either Text [RegistryEntry]) +loadRegistry reference = + (Right . registryEntries <$> evaluateRef reference) + `catch` \(e :: SomeException) -> pure (Left (Text.pack (show e))) + +-- | Parse, resolve imports, type check, and normalize a registry reference. +evaluateRef :: RegistryRef -> IO (Expr Src Void) +evaluateRef (RegistryFile path) = do + contents <- Text.IO.readFile path + Dhall.inputExprWithSettings + ( Dhall.defaultInputSettings + & set Dhall.rootDirectory (takeDirectory path) + & set Dhall.sourceName path + ) + contents +evaluateRef (RegistryExpression expression) = Dhall.inputExpr expression + +-- | Every profile in a normalized registry expression, sorted by export path. +-- +-- The rule, stated plainly: if the whole expression decodes as a profile, that +-- is the single entry (with an empty export path). Otherwise, if it is a record +-- literal that is not a schema record, visit each field under a dot-qualified +-- path and apply the same rule. Anything else contributes nothing. +-- +-- Detection is \"decodes successfully\", not type equality: Dhall record +-- extraction ignores fields the decoder does not ask for, so a registry +-- publishing locally extended profiles still enumerates. +registryEntries :: Expr Src Void -> [RegistryEntry] +registryEntries expression = List.sortOn (^. #export) (walk "" expression) + where + walk path expr = + case profileAt expr of + Just profileSpec -> [RegistryEntry {export = path, spec = profileSpec}] + Nothing -> + case expr of + RecordLit fields + | not (isSchemaRecord fields) -> + concat + [ walk (qualify path label) (recordFieldValue entry) + | (label, entry) <- Dhall.Map.toList fields + ] + _ -> [] + + qualify "" label = label + qualify path label = path <> "." <> label + + -- Dhall's record-completion idiom exports a schema as @{ Type, default }@. + -- Those are not profiles, and today they are rejected anyway because no + -- profile @default@ supplies @name@. Skipping them explicitly means a + -- future default that gained a @name@ could not start showing up as a + -- phantom profile. + isSchemaRecord fields = + isJust (Dhall.Map.lookup "Type" fields) + && isJust (Dhall.Map.lookup "default" fields) + +-- | Does this expression decode as a profile? Delegates to +-- 'Okf.Profile.decodeProfileExpr', which tries the current schema and then the +-- okf 0.2.x one, so a registry written before field descriptions existed — the +-- published @okf-profiles@ package included — still enumerates. It cannot +-- throw, which is what lets enumeration be a pure function over an +-- already-evaluated expression. +profileAt :: Expr Src Void -> Maybe ProfileSpec +profileAt = decodeProfileExpr + +-- | Look up an entry by its exact export path. +findRegistryEntry :: Text -> [RegistryEntry] -> Maybe RegistryEntry +findRegistryEntry path = List.find ((== path) . (^. #export)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,1090 +3,2567 @@ module Main (main) where import Data.Aeson (object, toJSON, (.=)) -import Data.Foldable (for_) -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 (setField, (.=)) -import Okf.Profile -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, - 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 "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 - ] - 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 False (spec ^. #allowUnknownTypes) - assertEqual ["type", "title"] (spec ^. #frontmatter . #required) - assertEqual - ["PostgreSQL Schema", "PostgreSQL Table", "PostgreSQL View"] - (map (^. #type_) (spec ^. #types)) - -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)) - -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) - --- | 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", - okfVersion = "0.1", - frontmatter = FrontmatterRules {required = ["type", "title"], recommended = []}, - allowUnknownTypes = False, - idField = Nothing, - types = - [ TypeRule - { type_ = "PostgreSQL Table", - pathPattern = Just "schemas/*/tables/*", - resourceScheme = Just "postgresql", - requireSchemaSection = True, - schemaColumns = ["Column", "Type", "Nullable", "Description"], - idPrefix = Nothing - } - ] - } - -testDocumentIdProfileSpec :: ProfileSpec -testDocumentIdProfileSpec = - ProfileSpec - { name = "test-decisions", - okfVersion = "0.1", - frontmatter = FrontmatterRules {required = ["type", "title"], recommended = []}, - allowUnknownTypes = False, - idField = Just "docId", - types = - [ TypeRule - { type_ = "Decision Record", - pathPattern = Just "decisions/*", - resourceScheme = Nothing, - requireSchemaSection = False, - schemaColumns = [], - idPrefix = Just "ADR" - } - ] - } - --- | 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 [] (validateProfile testProfileSpec [concept]) - -testProfileUnknownType :: Either Text () -testProfileUnknownType = do - concept <- - profileConcept - "schemas/sales/tables/bad" - [("type", String "pg table"), ("title", String "Bad"), ("resource", String "postgresql://x")] - schemaSectionBody - cid <- parseTestConceptId "schemas/sales/tables/bad" - assertEqual [TypeNotInProfile cid "pg table"] (validateProfile 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"] (validateProfile 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"] - (validateProfile 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/*"] - (validateProfile 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"] - (validateProfile 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"]] - (validateProfile 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 [] (validateProfile 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"] - (validateProfile 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" - ] - (validateProfile 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] - (validateProfile 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 [] (validateProfile 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"] - (validateProfile 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 - ] - (validateProfile spec concepts) +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 still accepts an okf 0.2.x descriptor" testLoadLegacyProfileFixture, + testIO "profileFieldDescription finds required and recommended prose" testProfileFieldDescription, + 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 "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 + ] + 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 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") + +-- | 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) + ] + ] + ], + "types" + .= [ object + [ "type" .= ("Decision Record" :: Text), + "description" + .= ("One accepted decision, never edited after acceptance." :: Text), + "frontmatter" + .= object + [ "required" .= ([] :: [FieldRule]), + "recommended" .= ([] :: [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 = [] + }, + 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 = [] + }, + 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 = []} + +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] + }, + 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] + }, + 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] + }, + 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] + }, + types = + [ withTypeFrontmatter + FrontmatterRules + { required = [FieldRule "status" Nothing ["approved", "archived"] Any Nothing Nothing Nothing Nothing], + recommended = [] + } + (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 = [] + } + (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] + } + typeRules cardinality = + FrontmatterRules + { required = [FieldRule "status" Nothing [] cardinality Nothing Nothing Nothing Nothing], + recommended = [] + } + 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] + }, + 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 = [] + }, + types = + [ withTypeFrontmatter + FrontmatterRules + { required = [FieldRule "homepage" Nothing [] Any (Just typeFormat) Nothing Nothing Nothing], + recommended = [] + } + 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 = [] + }, + 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] + }, + 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] + }, + 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] + } + typeRules = + NestedRules + { required = + [ NestedFieldRule "kind" Nothing ["implementation", "operations"] Any Nothing Nothing, + NestedFieldRule "outcome" Nothing ["approved", "rejected"] Any Nothing Nothing + ], + recommended = [] + } + 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 = [] + }, + 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 = [] + }, + 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] + } + +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 = []}, + 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 = [] + } + crossScopeProfile = + typeAwareProfileSpec + { frontmatter = + FrontmatterRules + { required = + [ source "status" ["active"] Scalar, + FieldRule "reviews" Nothing [] List Nothing (Just nestedCrossScope) Nothing Nothing + ], + recommended = [] + }, + 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]}, + allowUnknownTypes = True, + types = + [ withTypeFrontmatter + FrontmatterRules {required = [requiredTarget], recommended = []} + (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"]))] + } + 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 = []}, + 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 = []} + 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 + } + 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]) + +testClosedFieldValidation :: Either Text () +testClosedFieldValidation = do + let ownedRule :: TypeRule + ownedRule = + withTypeFrontmatter + FrontmatterRules {required = [requiredField "owner"], recommended = []} + (firstTypeRule typeAwareProfileSpec) + reviewRule = + withTypeName + "Review" + (withTypeFrontmatter FrontmatterRules {required = [requiredField "reviewer"], recommended = []} ownedRule) + closed = + typeAwareProfileSpec + { frontmatter = FrontmatterRules {required = [requiredField "type", requiredField "status"], recommended = []}, + 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 = diff --git a/test/fixtures/profile-cardinality/bad.md b/test/fixtures/profile-cardinality/bad.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-cardinality/bad.md @@ -0,0 +1,9 @@ +--- +type: Cardinality Concept +title: [One, Two] +tags: one +domain: false +score: 3 +--- + +# Bad cardinality diff --git a/test/fixtures/profile-cardinality/good.md b/test/fixtures/profile-cardinality/good.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-cardinality/good.md @@ -0,0 +1,9 @@ +--- +type: Cardinality Concept +title: One +tags: [one, two] +domain: false +score: 3 +--- + +# Good cardinality diff --git a/test/fixtures/profile-cardinality/log.md b/test/fixtures/profile-cardinality/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-cardinality/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-07-29 +* **Add**: Created the cardinality validation fixture. diff --git a/test/fixtures/profile-closed-fields/log.md b/test/fixtures/profile-closed-fields/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-closed-fields/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-07-29 +* **Add**: Created the closed-profile typo fixture. diff --git a/test/fixtures/profile-closed-fields/requests/typo.md b/test/fixtures/profile-closed-fields/requests/typo.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-closed-fields/requests/typo.md @@ -0,0 +1,13 @@ +--- +type: Improvement Request +title: Close field names +description: Exercises a misspelled required field. +timestamp: 2026-07-29T00:00:00Z +resource: https://example.test/requests/IR-1 +tags: [profiles] +requestId: IR-1 +owner: Ari +stauts: proposed +--- + +# Close field names diff --git a/test/fixtures/profile-conditions/decisions/active.md b/test/fixtures/profile-conditions/decisions/active.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/decisions/active.md @@ -0,0 +1,6 @@ +--- +type: Decision Record +status: active +--- + +# Active decision diff --git a/test/fixtures/profile-conditions/decisions/missing-status.md b/test/fixtures/profile-conditions/decisions/missing-status.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/decisions/missing-status.md @@ -0,0 +1,5 @@ +--- +type: Decision Record +--- + +# Decision without status diff --git a/test/fixtures/profile-conditions/decisions/superseded.md b/test/fixtures/profile-conditions/decisions/superseded.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/decisions/superseded.md @@ -0,0 +1,6 @@ +--- +type: Decision Record +status: superseded +--- + +# Superseded decision diff --git a/test/fixtures/profile-conditions/log.md b/test/fixtures/profile-conditions/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/log.md @@ -0,0 +1,5 @@ +# Log + +## 2026-07-29 + +- Added conditional profile acceptance fixtures. diff --git a/test/fixtures/profile-conditions/postgresql/operational.md b/test/fixtures/profile-conditions/postgresql/operational.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/postgresql/operational.md @@ -0,0 +1,6 @@ +--- +type: PostgreSQL Derivation +derivationKind: operational +--- + +# Operational derivation diff --git a/test/fixtures/profile-conditions/postgresql/projection.md b/test/fixtures/profile-conditions/postgresql/projection.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/postgresql/projection.md @@ -0,0 +1,6 @@ +--- +type: PostgreSQL Derivation +derivationKind: projection +--- + +# Projection derivation diff --git a/test/fixtures/profile-conditions/reviews/mixed.md b/test/fixtures/profile-conditions/reviews/mixed.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-conditions/reviews/mixed.md @@ -0,0 +1,10 @@ +--- +type: Reviewed Concept +reviews: + - kind: model + reviewer: Codex + - kind: human + reviewer: Ari +--- + +# Mixed reviews diff --git a/test/fixtures/profile-document-references/decisions/duplicate-a.md b/test/fixtures/profile-document-references/decisions/duplicate-a.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-document-references/decisions/duplicate-a.md @@ -0,0 +1,7 @@ +--- +type: Decision Record +title: Duplicate A +docId: ADR-3 +--- + +# Duplicate A diff --git a/test/fixtures/profile-document-references/decisions/duplicate-b.md b/test/fixtures/profile-document-references/decisions/duplicate-b.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-document-references/decisions/duplicate-b.md @@ -0,0 +1,7 @@ +--- +type: Decision Record +title: Duplicate B +docId: ADR-3 +--- + +# Duplicate B diff --git a/test/fixtures/profile-document-references/decisions/source.md b/test/fixtures/profile-document-references/decisions/source.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-document-references/decisions/source.md @@ -0,0 +1,18 @@ +--- +type: Decision Record +title: Source +docId: ADR-1 +references: + - ADR-2 + - ADR-99 + - PAT-3 + - not a reference + - https://example.test/external + - MORI://shinzui/okf/docs/one + - ADR-1 + - 7 + - ADR-3 +selfReference: ADR-1 +--- + +# Source diff --git a/test/fixtures/profile-document-references/decisions/target.md b/test/fixtures/profile-document-references/decisions/target.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-document-references/decisions/target.md @@ -0,0 +1,7 @@ +--- +type: Decision Record +title: Target +docId: ADR-2 +--- + +# Target diff --git a/test/fixtures/profile-formats/bad.md b/test/fixtures/profile-formats/bad.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-formats/bad.md @@ -0,0 +1,13 @@ +--- +type: Format Concept +title: Bad formats +timestamp: 2026-07-29T17:00:00+01:00 +published: 2026-13-45 +homepage: mailto:owner@example.test +docId: ADR-007 +links: + - https://example.test/good + - https://example.test/bad%ZZ +--- + +# Bad formats diff --git a/test/fixtures/profile-formats/good.md b/test/fixtures/profile-formats/good.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-formats/good.md @@ -0,0 +1,13 @@ +--- +type: Format Concept +title: Good formats +timestamp: 2026-07-29T17:00:00Z +published: 2024-02-29 +homepage: HTTPS://example.test/good +docId: ADR-7 +links: + - https://example.test/one + - urn:example:two +--- + +# Good formats diff --git a/test/fixtures/profile-formats/log.md b/test/fixtures/profile-formats/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-formats/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-07-29 +* **Add**: Created the named-format validation fixture. diff --git a/test/fixtures/profile-nested-reviews-valid/good.md b/test/fixtures/profile-nested-reviews-valid/good.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-nested-reviews-valid/good.md @@ -0,0 +1,20 @@ +--- +type: Reviewed Concept +title: Good review +description: A complete nested review record. +timestamp: 2026-07-29T17:00:00Z +reviews: + - kind: model + reviewer: Ari + reviewed_at: 2026-07-29T16:00:00Z + document_timestamp: 2026-07-29T17:00:00Z + scope: technical-accuracy + outcome: approved + context: Complete review + notes: No blockers + provider: openai + model: gpt-5.6-sol + effort: xhigh +--- + +# Good review diff --git a/test/fixtures/profile-nested-reviews-valid/log.md b/test/fixtures/profile-nested-reviews-valid/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-nested-reviews-valid/log.md @@ -0,0 +1,5 @@ +# Log + +## 2026-07-29 + +- Added a valid nested review fixture. diff --git a/test/fixtures/profile-nested-reviews/bad.md b/test/fixtures/profile-nested-reviews/bad.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-nested-reviews/bad.md @@ -0,0 +1,25 @@ +--- +type: Reviewed Concept +title: Bad reviews +description: Exercises indexed nested review diagnostics. +timestamp: 2026-07-29T17:00:00Z +reviews: + - kind: human + reviewer: Ari + reviewed_at: 2026-07-29T16:00:00Z + document_timestamp: 2026-07-29T17:00:00Z + scope: content + outcome: approved + context: Baseline + notes: Present + - not-a-record + - kind: model + reviewer: Bo + reviewed_at: 2026-13-45T99:99:99Z + document_timestamp: 2026-07-29T17:00:00Z + scope: invalid + context: + - wrong +--- + +# Bad reviews diff --git a/test/fixtures/profile-nested-reviews/good.md b/test/fixtures/profile-nested-reviews/good.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-nested-reviews/good.md @@ -0,0 +1,20 @@ +--- +type: Reviewed Concept +title: Good review +description: A complete nested review record. +timestamp: 2026-07-29T17:00:00Z +reviews: + - kind: model + reviewer: Ari + reviewed_at: 2026-07-29T16:00:00Z + document_timestamp: 2026-07-29T17:00:00Z + scope: technical-accuracy + outcome: approved + context: Complete review + notes: No blockers + provider: openai + model: gpt-5.6-sol + effort: xhigh +--- + +# Good review diff --git a/test/fixtures/profile-nested-reviews/log.md b/test/fixtures/profile-nested-reviews/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-nested-reviews/log.md @@ -0,0 +1,5 @@ +# Log + +## 2026-07-29 + +- Added nested review validation fixtures. diff --git a/test/fixtures/profile-type-frontmatter/log.md b/test/fixtures/profile-type-frontmatter/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-type-frontmatter/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-07-29 +* **Add**: Created the type-aware profile validation fixture. diff --git a/test/fixtures/profile-type-frontmatter/open.md b/test/fixtures/profile-type-frontmatter/open.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-type-frontmatter/open.md @@ -0,0 +1,8 @@ +--- +type: Open Concept +title: Open +description: An open concept. +timestamp: 2026-07-29T00:00:00Z +--- + +# Open diff --git a/test/fixtures/profile-type-frontmatter/owned.md b/test/fixtures/profile-type-frontmatter/owned.md new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-type-frontmatter/owned.md @@ -0,0 +1,9 @@ +--- +type: Owned Concept +title: Owned +description: An owned concept. +timestamp: 2026-07-29T00:00:00Z +owner: Ari +--- + +# Owned diff --git a/test/fixtures/profiles/cardinality-ep3.dhall b/test/fixtures/profiles/cardinality-ep3.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/cardinality-ep3.dhall @@ -0,0 +1,47 @@ +-- Frozen EP-3 shape, before named formats were added. Keep this descriptor +-- unannotated and unchanged so it exercises the dedicated compatibility decoder. +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + } + +in { name = "cardinality-ep3" + , description = Some "A profile from the EP-3 schema generation." + , okfVersion = "0.1" + , frontmatter = + { required = + [ { field = "type" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + } + , { field = "score" + , description = Some "A scalar score." + , allowedValues = [] : List Text + , cardinality = Cardinality.Scalar + } + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = False + , allowUnknownFields = False + , idField = None Text + , types = + [ { type = "EP-3 Concept" + , description = None Text + , frontmatter = + { required = [] : List FieldRule + , recommended = [] : List FieldRule + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] + } diff --git a/test/fixtures/profiles/cardinality.dhall b/test/fixtures/profiles/cardinality.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/cardinality.dhall @@ -0,0 +1,34 @@ +let Profile = ../../../dhall/Profile.dhall + +let FieldRule = ../../../dhall/FieldRule.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +in { name = "cardinality" + , description = Some "Exercises scalar and list field cardinality." + , okfVersion = "0.1" + , frontmatter = + { required = + [ field.plain "type" + , field.scalar "title" + , field.list "tags" + , field.scalar "domain" + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = None Text + , types = + [ TypeRule::{ + , type = "Cardinality Concept" + , frontmatter = + { required = [ field.scalar "score" ] + , recommended = [] : List FieldRule + } + } + ] + } + : Profile diff --git a/test/fixtures/profiles/closed-fields.dhall b/test/fixtures/profiles/closed-fields.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/closed-fields.dhall @@ -0,0 +1,42 @@ +let Profile = ../../../dhall/Profile.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let FieldRule = ../../../dhall/FieldRule.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +in { name = "closed-fields" + , description = Some "Exercises closed field names and value vocabularies." + , okfVersion = "0.1" + , frontmatter = + { required = + [ field.plain "type" + , field.enum "status" [ "proposed", "accepted", "closed" ] + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = False + , allowUnknownFields = False + , idField = Some "requestId" + , types = + [ TypeRule::{ + , type = "Improvement Request" + , frontmatter = + { required = + [ field.enum "status" [ "proposed", "accepted" ] + , field.plain "owner" + ] + , recommended = [] : List FieldRule + } + } + , TypeRule::{ + , type = "Review" + , frontmatter = + { required = [ field.plain "reviewer" ] + , recommended = [] : List FieldRule + } + } + ] + } + : Profile diff --git a/test/fixtures/profiles/conditional-fields-ep2.dhall b/test/fixtures/profiles/conditional-fields-ep2.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/conditional-fields-ep2.dhall @@ -0,0 +1,117 @@ +--| Frozen condition-aware descriptor generation from MasterPlan 5 EP-2. +-- It deliberately has no `reference` field so the compatibility decoder must +-- preserve both top-level and nested `when` values while adding `None`. +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let FieldCondition = { field : Text, hasValue : List Text } + +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 + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , when : Optional FieldCondition + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : 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 + } + +in { name = "conditional-fields-ep2" + , description = None Text + , okfVersion = "0.1" + , frontmatter = + { required = + [ { field = "status" + , description = None Text + , allowedValues = [ "active", "superseded" ] + , cardinality = Cardinality.Scalar + , format = None FieldFormat + , elementFields = None NestedRules + , when = None FieldCondition + } + , { field = "supersededBy" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Scalar + , format = None FieldFormat + , elementFields = None NestedRules + , when = Some { field = "status", hasValue = [ "superseded" ] } + } + , { field = "reviews" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.List + , format = None FieldFormat + , elementFields = + Some + { required = + [ { field = "kind" + , description = None Text + , allowedValues = [ "human", "model" ] + , cardinality = Cardinality.Scalar + , format = None FieldFormat + , when = None FieldCondition + } + , { field = "provider" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Scalar + , format = None FieldFormat + , when = Some { field = "kind", hasValue = [ "model" ] } + } + ] + , recommended = [] : List NestedFieldRule + } + , when = None FieldCondition + } + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = True + , allowUnknownFields = True + , idField = None Text + , types = [] : List TypeRule + } + : Profile diff --git a/test/fixtures/profiles/conditional-fields-invalid.dhall b/test/fixtures/profiles/conditional-fields-invalid.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/conditional-fields-invalid.dhall @@ -0,0 +1,25 @@ +let okf = ../../../dhall/package.dhall + +let Profile = okf.defaults.Profile + +let FieldRule = okf.defaults.FieldRule + +let Cardinality = okf.Cardinality + +in Profile::{ + , name = "invalid-conditional-fields" + , frontmatter = + { required = + [ FieldRule::{ + , field = "status" + , allowedValues = [ "active" ] + , cardinality = Cardinality.Scalar + } + , FieldRule::{ + , field = "supersededBy" + , when = Some { field = "status", hasValue = [ "superseded" ] } + } + ] + , recommended = [] : List FieldRule.Type + } + } diff --git a/test/fixtures/profiles/conditional-fields.dhall b/test/fixtures/profiles/conditional-fields.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/conditional-fields.dhall @@ -0,0 +1,110 @@ +let okf = ../../../dhall/package.dhall + +let Profile = okf.defaults.Profile + +let TypeRule = okf.defaults.TypeRule + +let FieldRule = okf.defaults.FieldRule + +let NestedFieldRule = okf.defaults.NestedFieldRule + +let Cardinality = okf.Cardinality + +let condition = \(field : Text) -> \(hasValue : List Text) -> { field, hasValue } + +let decision = + TypeRule::{ + , type = "Decision Record" + , frontmatter = + { required = + [ FieldRule::{ + , field = "status" + , allowedValues = [ "active", "superseded" ] + , cardinality = Cardinality.Scalar + } + , FieldRule::{ + , field = "supersededBy" + , cardinality = Cardinality.Scalar + , when = Some (condition "status" [ "superseded" ]) + } + ] + , recommended = [] : List FieldRule.Type + } + } + +let postgresql = + TypeRule::{ + , type = "PostgreSQL Derivation" + , frontmatter = + { required = + [ FieldRule::{ + , field = "derivationKind" + , allowedValues = [ "projection", "operational" ] + , cardinality = Cardinality.Scalar + } + , FieldRule::{ + , field = "sourceQuery" + , cardinality = Cardinality.Scalar + , when = Some (condition "derivationKind" [ "projection" ]) + } + ] + , recommended = + [ FieldRule::{ + , field = "runbook" + , cardinality = Cardinality.Scalar + , when = Some (condition "derivationKind" [ "operational" ]) + } + ] + } + } + +let reviewed = + TypeRule::{ + , type = "Reviewed Concept" + , frontmatter = + { required = + [ okf.mk.FieldRule.recordList + "reviews" + { required = + [ NestedFieldRule::{ + , field = "kind" + , allowedValues = [ "human", "model" ] + , cardinality = Cardinality.Scalar + } + , NestedFieldRule::{ + , field = "reviewer" + , cardinality = Cardinality.Scalar + } + , NestedFieldRule::{ + , field = "provider" + , cardinality = Cardinality.Scalar + , when = Some (condition "kind" [ "model" ]) + } + , NestedFieldRule::{ + , field = "model" + , cardinality = Cardinality.Scalar + , when = Some (condition "kind" [ "model" ]) + } + , NestedFieldRule::{ + , field = "effort" + , allowedValues = [ "low", "medium", "high", "xhigh" ] + , cardinality = Cardinality.Scalar + , when = Some (condition "kind" [ "model" ]) + } + ] + , recommended = [] : List NestedFieldRule.Type + } + ] + , recommended = [] : List FieldRule.Type + } + } + +in Profile::{ + , name = "conditional-fields" + , allowUnknownTypes = False + , frontmatter = + { required = [ okf.mk.FieldRule.plain "type" ] + , recommended = [] : List FieldRule.Type + } + , types = [ decision, postgresql, reviewed ] + } 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 @@ -1,18 +1,35 @@ -- The annotation and TypeRule record completion jointly guard the canonical --- schema, its defaults, and the Haskell decoder against drift. +-- schema, its defaults, and the Haskell decoder against drift. This fixture +-- writes its frontmatter with the `mk/FieldRule.dhall` constructors; the +-- postgresql fixture writes its own with record completion, so both authoring +-- forms stay exercised by the suite. let Profile = ../../../dhall/Profile.dhall let TypeRule = ../../../dhall/defaults/TypeRule.dhall +let field = ../../../dhall/mk/FieldRule.dhall + in { name = "decisions" + , description = Some "How this team records architectural decisions." , okfVersion = "0.1" , frontmatter = - { required = [ "type", "title" ], recommended = [] : List Text } + { required = + [ field.documented + "type" + "The OKF concept type; must be a type rule below." + , field.plain "title" + ] + , recommended = + [ field.documented "status" "One of: proposed, accepted, superseded." ] + } , allowUnknownTypes = False + , allowUnknownFields = True , idField = Some "docId" , types = [ TypeRule::{ , type = "Decision Record" + , description = Some + "One accepted decision, never edited after acceptance." , pathPattern = Some "decisions/*" , idPrefix = Some "ADR" } diff --git a/test/fixtures/profiles/described.dhall b/test/fixtures/profiles/described.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/described.dhall @@ -0,0 +1,24 @@ +-- Frozen self-documenting shape from before TypeRule gained frontmatter. +-- Keep this descriptor unannotated and unchanged so it exercises the middle +-- compatibility decoder rather than the current published schema. +{ name = "described" +, description = Some "A pre-type-frontmatter profile." +, okfVersion = "0.1" +, frontmatter = + { required = + [ { field = "type", description = Some "The concept type." } ] + , recommended = [] : List { field : Text, description : Optional Text } + } +, allowUnknownTypes = False +, idField = None Text +, types = + [ { type = "Described Concept" + , description = Some "A concept from the described schema generation." + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] +} diff --git a/test/fixtures/profiles/document-references-invalid.dhall b/test/fixtures/profiles/document-references-invalid.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/document-references-invalid.dhall @@ -0,0 +1,57 @@ +--| Semantically invalid reference policies; Dhall accepts the shape and +-- compileProfile rejects the policy errors before bundle traversal. +let Profile = ../../../dhall/Profile.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let HandleReferenceRule = ../../../dhall/defaults/HandleReferenceRule.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let policy = + \(localPrefix : Text) -> + \(externalUriSchemes : List Text) -> + Some HandleReferenceRule::{ localPrefix, externalUriSchemes } + +let rule = + \(field : Text) -> + \(localPrefix : Text) -> + \(externalUriSchemes : List Text) -> + FieldRule::{ field, reference = policy localPrefix externalUriSchemes } + +in { name = "invalid-document-references" + , description = None Text + , okfVersion = "0.1" + , frontmatter = + { required = + [ rule "badPrefix" "1ADR" ([] : List Text) + , rule "undeclared" "PAT" ([] : List Text) + , rule "badScheme" "ADR" [ "mori_" ] + , FieldRule::{ + , field = "formatted" + , format = Some (FieldFormat.DocumentHandle "ADR") + , reference = policy "ADR" ([] : List Text) + } + , rule "conflict" "ADR" ([] : List Text) + ] + , recommended = [] : List FieldRule.Type + } + , allowUnknownTypes = True + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ TypeRule::{ + , type = "Decision Record" + , frontmatter = + { required = [ rule "conflict" "RFC" ([] : List Text) ] + , recommended = [] : List FieldRule.Type + } + , idPrefix = Some "ADR" + } + , TypeRule::{ type = "RFC", idPrefix = Some "RFC" } + , TypeRule::{ type = "Invalid Prefix", idPrefix = Some "1ADR" } + ] + } + : Profile diff --git a/test/fixtures/profiles/document-references.dhall b/test/fixtures/profiles/document-references.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/document-references.dhall @@ -0,0 +1,45 @@ +--| Current schema fixture for bundle-local handles and explicit external URIs. +let Profile = ../../../dhall/Profile.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let HandleReferenceRule = ../../../dhall/defaults/HandleReferenceRule.dhall + +let Cardinality = ../../../dhall/Cardinality.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +let references = + (field.localOrExternalReference "references" "ADR" [ "mori" ]) + with cardinality = Cardinality.List + +let selfReference = + FieldRule::{ + , field = "selfReference" + , cardinality = Cardinality.Scalar + , reference = + Some HandleReferenceRule::{ localPrefix = "ADR", allowSelf = True } + } + +in { name = "document-references" + , description = Some + "Architecture decisions with bundle-local or explicitly external references." + , okfVersion = "0.1" + , frontmatter = + { required = [ field.plain "type", field.plain "title" ] + , recommended = [ references, selfReference ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ TypeRule::{ + , type = "Decision Record" + , pathPattern = Some "decisions/*" + , idPrefix = Some "ADR" + } + ] + } + : Profile diff --git a/test/fixtures/profiles/formats-ep4.dhall b/test/fixtures/profiles/formats-ep4.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/formats-ep4.dhall @@ -0,0 +1,52 @@ +-- Frozen EP-4 shape, before bounded nested records were added. Keep this +-- descriptor unannotated and unchanged so it exercises the dedicated decoder. +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + } + +in { name = "formats-ep4" + , description = Some "A profile from the EP-4 schema generation." + , okfVersion = "0.1" + , frontmatter = + { required = + [ { field = "type" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.Any + , format = None FieldFormat + } + , { field = "timestamp" + , description = Some "A UTC timestamp." + , allowedValues = [] : List Text + , cardinality = Cardinality.Scalar + , format = Some FieldFormat.Rfc3339Utc + } + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = False + , allowUnknownFields = False + , idField = None Text + , types = + [ { type = "EP-4 Concept" + , description = None Text + , frontmatter = + { required = [] : List FieldRule + , recommended = [] : List FieldRule + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] + } diff --git a/test/fixtures/profiles/formats.dhall b/test/fixtures/profiles/formats.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/formats.dhall @@ -0,0 +1,44 @@ +let Profile = ../../../dhall/Profile.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let Cardinality = ../../../dhall/Cardinality.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +in { name = "formats" + , description = Some "Exercises named textual field formats." + , okfVersion = "0.1" + , frontmatter = + { required = + [ field.plain "type" + , field.rfc3339Utc "timestamp" + , field.date "published" + , field.uri "homepage" + , field.documentHandle "docId" "ADR" + , FieldRule::{ + , field = "links" + , cardinality = Cardinality.List + , format = Some FieldFormat.Uri + } + ] + , recommended = [] : List FieldRule.Type + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "docId" + , types = + [ TypeRule::{ + , type = "Format Concept" + , frontmatter = + { required = [ field.uriWithScheme "homepage" "https" ] + , recommended = [] : List FieldRule.Type + } + } + ] + } + : Profile diff --git a/test/fixtures/profiles/legacy-0.2.dhall b/test/fixtures/profiles/legacy-0.2.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/legacy-0.2.dhall @@ -0,0 +1,20 @@ +-- Frozen okf 0.2.0.0 profile descriptor. Deliberately NOT annotated against the +-- current schema and deliberately never updated: it exists so the legacy fallback +-- decoder in okf-core/src/Okf/Profile.hs stays exercised. If this file ever needs +-- to change to keep a test passing, the backwards-compatibility guarantee has +-- been broken. +{ name = "legacy" +, okfVersion = "0.1" +, frontmatter = { required = [ "type", "title" ], recommended = [] : List Text } +, allowUnknownTypes = False +, idField = None Text +, types = + [ { type = "Legacy Concept" + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] +} diff --git a/test/fixtures/profiles/nested-reviews-ep1.dhall b/test/fixtures/profiles/nested-reviews-ep1.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/nested-reviews-ep1.dhall @@ -0,0 +1,82 @@ +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + } + +let FrontmatterRules = + { required : List FieldRule, recommended : 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 + } + +in { name = "nested-ep1" + , description = None Text + , okfVersion = "0.1" + , frontmatter = + { required = + [ { field = "reviews" + , description = None Text + , allowedValues = [] : List Text + , cardinality = Cardinality.List + , format = None FieldFormat + , elementFields = + Some + { required = + [ { field = "kind" + , description = None Text + , allowedValues = [ "human", "model" ] + , cardinality = Cardinality.Scalar + , format = None FieldFormat + } + ] + , recommended = [] : List NestedFieldRule + } + } + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = True + , allowUnknownFields = True + , idField = None Text + , types = [] : List TypeRule + } : Profile diff --git a/test/fixtures/profiles/nested-reviews.dhall b/test/fixtures/profiles/nested-reviews.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/nested-reviews.dhall @@ -0,0 +1,64 @@ +let Profile = ../../../dhall/Profile.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let NestedFieldRule = ../../../dhall/defaults/NestedFieldRule.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +in { name = "nested-reviews" + , description = Some "Validates one level of structured review records." + , okfVersion = "0.1" + , frontmatter = + { required = + [ field.plain "type" + , field.recordList + "reviews" + { required = + [ NestedFieldRule::{ + , field = "kind" + , allowedValues = [ "human", "model" ] + } + , NestedFieldRule::{ field = "reviewer", cardinality = Cardinality.Scalar } + , NestedFieldRule::{ + , field = "reviewed_at" + , format = Some FieldFormat.Rfc3339Utc + } + , NestedFieldRule::{ + , field = "document_timestamp" + , format = Some FieldFormat.Rfc3339Utc + } + , NestedFieldRule::{ + , field = "scope" + , allowedValues = + [ "content" + , "technical-accuracy" + , "editorial" + , "catalog-metadata" + , "content-and-metadata" + ] + } + , NestedFieldRule::{ + , field = "outcome" + , allowedValues = [ "approved", "changes-requested", "commented" ] + } + , NestedFieldRule::{ field = "context", cardinality = Cardinality.Scalar } + ] + , recommended = + [ NestedFieldRule::{ field = "notes", cardinality = Cardinality.Scalar } ] + } + ] + , recommended = [] : List FieldRule.Type + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = None Text + , types = [ TypeRule::{ type = "Reviewed Concept" } ] + } + : 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 @@ -1,18 +1,56 @@ -- The `: Profile` annotation here is load-bearing: it ties this fixture to the -- canonical schema, so the `testLoadProfileFixture` round-trip in test/Main.hs -- fails if okf's published Dhall schema and the Haskell decoder ever drift apart. +-- Frontmatter here is written with FieldRule record completion; the decisions +-- fixture uses the `mk/FieldRule.dhall` constructors instead, so both authoring +-- forms stay exercised. let Profile = ../../../dhall/Profile.dhall +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + in { name = "shinzui-postgresql" + , description = Some + "Conventions for documenting a PostgreSQL database as an OKF bundle." , okfVersion = "0.1" , frontmatter = - { required = [ "type", "title" ] - , recommended = [ "description", "timestamp", "resource" ] + { required = + [ FieldRule::{ + , field = "type" + , description = Some + "The OKF concept type; must be one of the type rules below." + } + , FieldRule::{ + , field = "title" + , description = Some + "Human-readable name of the object, as a reader would say it." + } + ] + , recommended = + [ FieldRule::{ + , field = "description" + , description = Some + "One or two sentences on what this object is for." + } + , FieldRule::{ + , field = "timestamp" + , format = Some FieldFormat.Rfc3339Utc + } + , FieldRule::{ + , field = "resource" + , description = Some "postgresql:// URI locating the live object." + , format = Some (FieldFormat.UriWithScheme "postgresql") + } + ] } , allowUnknownTypes = False + , allowUnknownFields = True , idField = None Text , types = [ { type = "PostgreSQL Schema" + , description = Some "One namespace grouping tables and views." + , frontmatter = { required = [] : List FieldRule.Type, recommended = [] : List FieldRule.Type } , pathPattern = Some "schemas/*" , resourceScheme = Some "postgresql" , requireSchemaSection = False @@ -20,6 +58,9 @@ , idPrefix = None Text } , { type = "PostgreSQL Table" + , description = Some + "One physical table in a schema, including its column list." + , frontmatter = { required = [] : List FieldRule.Type, recommended = [] : List FieldRule.Type } , pathPattern = Some "schemas/*/tables/*" , resourceScheme = Some "postgresql" , requireSchemaSection = True @@ -27,6 +68,8 @@ , idPrefix = None Text } , { type = "PostgreSQL View" + , description = Some "One view, including the columns it projects." + , frontmatter = { required = [] : List FieldRule.Type, recommended = [] : List FieldRule.Type } , pathPattern = Some "schemas/*/views/*" , resourceScheme = Some "postgresql" , requireSchemaSection = True diff --git a/test/fixtures/profiles/type-aware-ep1.dhall b/test/fixtures/profiles/type-aware-ep1.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/type-aware-ep1.dhall @@ -0,0 +1,27 @@ +-- Frozen type-aware shape from EP-1, before field vocabularies and closed +-- field names. Keep this descriptor unannotated and unchanged so it exercises +-- the dedicated compatibility decoder. +{ name = "type-aware-ep1" +, description = Some "A profile from the EP-1 schema generation." +, okfVersion = "0.1" +, frontmatter = + { required = [ { field = "type", description = None Text } ] + , recommended = [] : List { field : Text, description : Optional Text } + } +, allowUnknownTypes = False +, idField = None Text +, types = + [ { type = "EP-1 Concept" + , description = None Text + , frontmatter = + { required = [ { field = "owner", description = Some "Responsible person." } ] + , recommended = [] : List { field : Text, description : Optional Text } + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] +} diff --git a/test/fixtures/profiles/type-frontmatter.dhall b/test/fixtures/profiles/type-frontmatter.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/type-frontmatter.dhall @@ -0,0 +1,35 @@ +let Profile = ../../../dhall/Profile.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +let FieldRule = ../../../dhall/FieldRule.dhall + +in { name = "type-frontmatter" + , description = Some "Exercises profile-wide and type-specific field rules." + , okfVersion = "0.1" + , frontmatter = + { required = + [ field.plain "type" + , field.documented "title" "Human-readable concept title." + ] + , recommended = [] : List FieldRule + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = None Text + , types = + [ TypeRule::{ + , type = "Owned Concept" + , frontmatter = + { required = + [ field.documented "owner" "Person responsible for the concept." ] + , recommended = + [ field.documented "reviewer" "Person who independently reviewed it." ] + } + } + , TypeRule::{ type = "Open Concept" } + ] + } + : Profile diff --git a/test/fixtures/profiles/vocabulary-ep2.dhall b/test/fixtures/profiles/vocabulary-ep2.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/vocabulary-ep2.dhall @@ -0,0 +1,39 @@ +-- Frozen EP-2 shape, before cardinality was added. Keep this descriptor +-- unannotated and unchanged so it exercises the dedicated compatibility decoder. +{ name = "vocabulary-ep2" +, description = Some "A profile from the EP-2 schema generation." +, okfVersion = "0.1" +, frontmatter = + { required = + [ { field = "type", description = None Text, allowedValues = [] : List Text } + , { field = "status" + , description = Some "Lifecycle state." + , allowedValues = [ "draft", "accepted" ] + } + ] + , recommended = + [] : List + { field : Text, description : Optional Text, allowedValues : List Text } + } +, allowUnknownTypes = False +, allowUnknownFields = False +, idField = None Text +, types = + [ { type = "EP-2 Concept" + , description = None Text + , frontmatter = + { required = + [] : List + { field : Text, description : Optional Text, allowedValues : List Text } + , recommended = + [] : List + { field : Text, description : Optional Text, allowedValues : List Text } + } + , pathPattern = None Text + , resourceScheme = None Text + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + ] +} diff --git a/test/fixtures/registry/package.dhall b/test/fixtures/registry/package.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/registry/package.dhall @@ -0,0 +1,10 @@ +--| Fixture registry for Okf.Profile.Registry tests. Deliberately mixes profile +-- values, a nested namespace, a schema record, a non-profile field, and one +-- frozen okf 0.2.x descriptor, so the enumeration walk is exercised on every +-- shape it must handle — including a registry mixing old and new profiles. +{ Profile = ../../../dhall/defaults/Profile.dhall +, postgresql = ../profiles/postgresql.dhall +, legacy = ../profiles/legacy-0.2.dhall +, nested = { decisions = ../profiles/decisions.dhall } +, note = "not a profile" +}