diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,19 @@ ## [Unreleased] +## [0.12.0.0] - 2026-10-28 + +### Added + +- `Okf.Profile.Sweep`: enumerate and apply relaxations of an authored + `ProfileSpec`, load a sweep suite (acceptance bundles and `expected.json` + cases in file order), check its baseline, and observe each relaxation's + witnesses with the okf-profiles catalog's legacy predicate. `sweepProfile` + classifies each relaxation by evidence and proof: `behaviourKey` proves + inertness with documented erasures, composite policy units and + `admitValue` relaxations cover what one relaxation alone cannot show, and + `parseExceptions` reads a per-suite exception manifest. + ## [0.11.0.0] - 2026-10-28 ### Added 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.11.0.0 +version: 0.12.0.0 synopsis: Read, validate, index, and traverse Open Knowledge Format bundles @@ -27,6 +27,7 @@ extra-source-files: dhall/**/*.dhall test/fixtures/**/*.dhall + test/fixtures/**/*.json test/fixtures/**/*.md test/fixtures/**/*.py test/fixtures/**/*.sql @@ -73,6 +74,7 @@ Okf.Profile.Discovery Okf.Profile.Documentation Okf.Profile.Registry + Okf.Profile.Sweep Okf.Query Okf.Trust Okf.Validation diff --git a/src/Okf/Profile/Sweep.hs b/src/Okf/Profile/Sweep.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Profile/Sweep.hs @@ -0,0 +1,1432 @@ +-- | Load-bearing sweeps of a profile against its own test suite. +-- +-- A profile catalog tests each descriptor with acceptance bundles that must pass +-- and rejection cases that must each fail for one reason. A /sweep/ asks the +-- converse question: weaken one rule one way (a /relaxation/), and does some +-- rejection case notice? A rule no case notices is not load-bearing, and the +-- suite has a gap. +-- +-- The sweep relaxes the decoded 'ProfileSpec' in memory and recompiles it, per +-- [ADR 5](docs/adr/5-compile-profile-rules-before-validation.md): a relaxation +-- changes what the author wrote, and compilation decides what it means. Core +-- validation and log staleness do not depend on the profile, so every bundle is +-- loaded and checked once ('loadSuite', 'checkBaseline') and each relaxation +-- re-runs only the pure profile check ('observeRelaxation'). +-- +-- A case /meets its expectation/ under the predicate of the okf-profiles +-- catalog's @scripts\/profile_fixture_cases.py@: run without strict authoring, it +-- produces exactly the expected number of @profile: @ deviation lines and at +-- least one of them contains the expected field name. The predicate compares +-- rendered lines, and rendering belongs to the CLI, so the caller supplies the +-- renderer as a 'Render'. +module Okf.Profile.Sweep + ( -- * Rule identity + RuleScope (..), + PresenceList (..), + NestedContainer (..), + RuleLocation (..), + renderRuleLocation, + + -- * Relaxations + RelaxationKind (..), + TypeAttribute (..), + KindSet (..), + renderKindSet, + parseKindSet, + RelaxationTarget (..), + Relaxation (..), + relaxationId, + relaxationField, + relaxationKindName, + legacyKindName, + enumerateRelaxations, + applyRelaxation, + + -- * Suites + CaseExpectation (..), + SuiteBundle (..), + RejectionCase (..), + Suite (..), + SuiteError (..), + loadSuite, + parseExpectations, + + -- * Evaluation + Render, + BaselineFault (..), + PreparedSuite, + preparedSuite, + preparedProfile, + checkBaseline, + planRelaxations, + Observation (..), + observeRelaxation, + primaryWitness, + legacyOutcome, + compositeUnit, + + -- * Classification + BehaviourKey, + behaviourKey, + withBehaviourKey, + ExceptionClass (..), + SweepException (..), + loadExceptions, + parseExceptions, + Outcome (..), + outcomeName, + outcomeIsFailing, + SweepResult (..), + sweepProfile, + staleExceptions, + ) +where + +import Control.Exception (IOException, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.Decoding.ByteString.Lazy (lbsToTokens) +import Data.Aeson.Decoding.Tokens (TkArray (..), TkRecord (..), Tokens (..)) +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LazyBytes +import Data.Foldable (toList) +import Data.List qualified as List +import Data.Map.Lazy qualified as LazyMap +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, listToMaybe, mapMaybe) +import Data.Scientific (toBoundedInteger) +import Data.Text qualified as Text +import Okf.Bundle + ( BundleError, + BundleInventory, + Concept, + LogFile, + conceptIdOf, + conceptType, + walkBundle, + walkBundleInventory, + walkLogs, + ) +import Okf.ConceptId (ConceptId) +import Okf.Index (OkfVersion, VersionDeclaration, readBundleVersion) +import Okf.Prelude hiding (List, Object) +import Okf.Profile + ( Cardinality (..), + CompiledProfile, + EffectiveConceptConstraints, + EffectiveFieldRule, + FieldCondition, + FieldFormat (DocumentHandle), + FieldPath (..), + FieldPathSegment (..), + FieldRequirement, + FieldRule, + HandleReferenceRule, + PathReferenceRule, + ProfileDefinitionError, + ProfileSpec, + ProfileViolation (..), + TypeRule, + compileProfile, + compiledProfileBaseConstraints, + compiledProfileBaseRules, + compiledProfileConstraintsForType, + compiledProfileRequiredBundleVersion, + compiledProfileRulesForType, + compiledProfileSpec, + compiledProfileTypeNames, + fieldRuleAllowedValues, + fieldRuleCardinality, + fieldRuleDescription, + fieldRuleElementAllowsUnknownFields, + fieldRuleElementConstraints, + fieldRuleElementFields, + fieldRuleFormat, + fieldRuleObjectAllowsUnknownFields, + fieldRuleObjectConstraints, + fieldRuleObjectFields, + fieldRulePath, + fieldRulePresenceClauses, + fieldRuleReference, + fieldRuleUniqueBy, + presenceClauseCondition, + presenceClauseRequirement, + validateProfileVersion, + validateProfileWith, + ) +import Okf.Validation + ( BundleValidationError, + LogStaleness, + ValidationProfile (..), + logStaleness, + validateBundle, + validateBundleLogs, + ) +import System.FilePath (()) + +-- | Where a rule is declared: profile-wide, or under one concept type. +data RuleScope = ProfileScope | TypeScope !Text + deriving stock (Generic, Eq, Ord, Show) + +-- | Which presence list of a 'Okf.Profile.FrontmatterRules' or +-- 'Okf.Profile.NestedRules' holds the rule. +data PresenceList = RequiredList | RecommendedList | OptionalList + deriving stock (Generic, Eq, Ord, Show, Enum, Bounded) + +-- | The two nested record shapes a top-level rule can declare. +data NestedContainer = ElementFields | ObjectFields + deriving stock (Generic, Eq, Ord, Show) + +-- | One authored rule. 'Okf.Profile.compileProfile' rejects a field named twice +-- in one list at one scope, so scope, list and field identify a top-level rule, +-- and the optional nested part identifies a member of its element or object +-- record. Nested rules cannot nest further, so there are at most two levels. +data RuleLocation = RuleLocation + { scope :: !RuleScope, + list :: !PresenceList, + field :: !Text, + nested :: !(Maybe (NestedContainer, PresenceList, Text)) + } + deriving stock (Generic, Eq, Ord, Show) + +-- | @profile/required/status@, or +-- @type:Objective/required/keyResults/elementFields/required/id@. +renderRuleLocation :: RuleLocation -> Text +renderRuleLocation RuleLocation {scope, list = presenceList, field = fieldName, nested} = + Text.intercalate "/" $ + [renderScope scope, renderPresenceList presenceList, fieldName] + <> maybe [] (\(container, innerList, innerField) -> [renderContainer container, renderPresenceList innerList, innerField]) nested + +renderScope :: RuleScope -> Text +renderScope = \case + ProfileScope -> "profile" + TypeScope typeName -> "type:" <> typeName + +renderPresenceList :: PresenceList -> Text +renderPresenceList = \case + RequiredList -> "required" + RecommendedList -> "recommended" + OptionalList -> "optional" + +renderContainer :: NestedContainer -> Text +renderContainer = \case + ElementFields -> "elementFields" + ObjectFields -> "objectFields" + +-- | A type-scope attribute that is not a frontmatter rule. +data TypeAttribute = PathPattern | ResourceScheme | RequireSchemaSection | SchemaColumns | IdPrefix + deriving stock (Generic, Eq, Ord, Show) + +-- | One way to weaken one rule. The first seven after 'Presence' are the kinds +-- the okf-profiles Python sweep generates ('legacyKindName'). +data RelaxationKind + = -- | remove the rule from its list + Delete + | -- | move a @required@ rule to @optional@ at the same scope, dropping only its + -- @when@ gate, which governs presence alone + Presence + | -- | @allowedValues@ to @[]@, which means unconstrained + ClearVocabulary + | -- | append one value to a non-empty @allowedValues@ + AdmitValue !Text + | DropFormat + | DropUniqueBy + | -- | @allowSelf@ from 'False' to 'True' inside a handle @reference@ + AllowSelf + | -- | @allowLocal@ from 'False' to 'True' inside a handle @reference@ + AllowLocal + | DropExternalUriPattern + | DropCardinality + | DropCondition + | DropPath + | DropReference + | DropNested !NestedContainer + | DropTypeAttribute !TypeAttribute + | -- | composite unit: a list rule's cardinality to 'Any' and its + -- @elementFields@ dropped together + DropListShape + | -- | composite unit: a type's @idPrefix@ and the @DocumentHandle@ format of + -- its @idField@ rule dropped together + DropHandleIdentity + | -- | composite unit: a list rule's @uniqueBy@ dropped and its key member + -- demoted to @optional@ together, which the descriptor cannot express one + -- at a time + DropUniqueKey + deriving stock (Generic, Eq, Ord, Show) + +-- | Which kinds a sweep enumerates. 'LegacyKinds' reproduces the Python sweep; +-- 'DefaultKinds' adds presence demotion; 'AllKinds' adds every other kind. +data KindSet = LegacyKinds | DefaultKinds | AllKinds + deriving stock (Generic, Eq, Ord, Show) + +renderKindSet :: KindSet -> Text +renderKindSet = \case + LegacyKinds -> "legacy" + DefaultKinds -> "default" + AllKinds -> "all" + +parseKindSet :: Text -> Maybe KindSet +parseKindSet = \case + "legacy" -> Just LegacyKinds + "default" -> Just DefaultKinds + "all" -> Just AllKinds + _ -> Nothing + +-- | What a relaxation changes: one authored rule, or one type's attributes. +data RelaxationTarget = RuleTarget !RuleLocation | TypeTarget !Text + deriving stock (Generic, Eq, Ord, Show) + +data Relaxation = Relaxation + { target :: !RelaxationTarget, + kind :: !RelaxationKind + } + deriving stock (Generic, Eq, Ord, Show) + +-- | The target followed by @#@ and the kind, such as +-- @type:Launch/required/launchRef#allowLocal@. Stable: exception manifests name +-- relaxations by it. +relaxationId :: Relaxation -> Text +relaxationId Relaxation {target, kind} = renderTarget target <> "#" <> relaxationKindName kind + +renderTarget :: RelaxationTarget -> Text +renderTarget = \case + RuleTarget location -> renderRuleLocation location + TypeTarget typeName -> "type:" <> typeName + +-- | The innermost field name the relaxation weakens, or the empty text for a +-- type attribute. This is the name the legacy case order prefers. +relaxationField :: Relaxation -> Text +relaxationField Relaxation {target} = case target of + RuleTarget RuleLocation {field = fieldName, nested} -> + maybe fieldName (\(_, _, innerField) -> innerField) nested + TypeTarget _ -> "" + +relaxationKindName :: RelaxationKind -> Text +relaxationKindName = \case + Delete -> "delete" + Presence -> "presence" + ClearVocabulary -> "allowedValues" + AdmitValue value -> "admitValue:" <> value + DropFormat -> "format" + DropUniqueBy -> "uniqueBy" + AllowSelf -> "allowSelf" + AllowLocal -> "allowLocal" + DropExternalUriPattern -> "externalUriPattern" + DropCardinality -> "cardinality" + DropCondition -> "condition" + DropPath -> "path" + DropReference -> "reference" + DropNested container -> renderContainer container + DropTypeAttribute attribute -> case attribute of + PathPattern -> "pathPattern" + ResourceScheme -> "resourceScheme" + RequireSchemaSection -> "requireSchemaSection" + SchemaColumns -> "schemaColumns" + IdPrefix -> "idPrefix" + DropListShape -> "listShape" + DropHandleIdentity -> "handleIdentity" + DropUniqueKey -> "uniqueKey" + +-- | The kind string the Python sweep prints, when the kind is one it generates. +legacyKindName :: RelaxationKind -> Maybe Text +legacyKindName kind = case kind of + Delete -> Just (relaxationKindName kind) + ClearVocabulary -> Just (relaxationKindName kind) + DropFormat -> Just (relaxationKindName kind) + DropUniqueBy -> Just (relaxationKindName kind) + AllowSelf -> Just (relaxationKindName kind) + AllowLocal -> Just (relaxationKindName kind) + DropExternalUriPattern -> Just (relaxationKindName kind) + _ -> Nothing + +-- | Every applicable relaxation of the authored descriptor, in declaration +-- order: profile-wide rules, then each type's rules followed by its attributes; +-- within one scope the @required@, @recommended@ and @optional@ lists in turn; +-- and within one rule its own relaxations before those of its nested members. +-- +-- The legacy kinds follow the Python sweep's applicability: @allowedValues@ +-- only when non-empty, @format@ and @uniqueBy@ only when set, @allowSelf@ and +-- @allowLocal@ only when 'False' inside a handle @reference@ (never a @path@), +-- @externalUriPattern@ only when set, and @delete@ always. Unlike the Python +-- sweep, a rule that is the sole element of its list can be deleted. +enumerateRelaxations :: KindSet -> ProfileSpec -> [Relaxation] +enumerateRelaxations kinds spec = + scopeRelaxations kinds ProfileScope (spec ^. #frontmatter . #required) (spec ^. #frontmatter . #recommended) (spec ^. #frontmatter . #optional) + <> concat + [ scopeRelaxations kinds (TypeScope (rule ^. #type_)) (rule ^. #frontmatter . #required) (rule ^. #frontmatter . #recommended) (rule ^. #frontmatter . #optional) + <> typeRelaxations kinds rule + | rule <- spec ^. #types + ] + +scopeRelaxations :: KindSet -> RuleScope -> [FieldRule] -> [FieldRule] -> [FieldRule] -> [Relaxation] +scopeRelaxations kinds scope required recommended optional = + concat + [ fieldRuleRelaxations kinds (RuleLocation scope presenceList (rule ^. #field) Nothing) rule + | (presenceList, rules) <- [(RequiredList, required), (RecommendedList, recommended), (OptionalList, optional)], + rule <- rules + ] + +fieldRuleRelaxations :: KindSet -> RuleLocation -> FieldRule -> [Relaxation] +fieldRuleRelaxations kinds location rule = + map (Relaxation (RuleTarget location)) (ruleKinds kinds (location ^. #list) facts) + <> nestedRelaxations ElementFields (rule ^. #elementFields) + <> nestedRelaxations ObjectFields (rule ^. #objectFields) + where + facts = + RuleFacts + { allowedValues = rule ^. #allowedValues, + cardinality = rule ^. #cardinality, + format = rule ^. #format, + reference = rule ^. #reference, + path = rule ^. #path, + condition = rule ^. #when, + uniqueBy = rule ^. #uniqueBy, + hasElementFields = isJust (rule ^. #elementFields), + hasObjectFields = isJust (rule ^. #objectFields) + } + nestedRelaxations container = \case + Nothing -> [] + Just nestedRules -> + concat + [ map + (Relaxation (RuleTarget (location & #nested ?~ (container, presenceList, member ^. #field)))) + ( ruleKinds + kinds + presenceList + RuleFacts + { allowedValues = member ^. #allowedValues, + cardinality = member ^. #cardinality, + format = member ^. #format, + reference = member ^. #reference, + path = member ^. #path, + condition = member ^. #when, + uniqueBy = Nothing, + hasElementFields = False, + hasObjectFields = False + } + ) + | (presenceList, members) <- + [ (RequiredList, nestedRules ^. #required), + (RecommendedList, nestedRules ^. #recommended), + (OptionalList, nestedRules ^. #optional) + ], + member <- members + ] + +-- | What enumeration needs to know about one rule, top-level or nested. +data RuleFacts = RuleFacts + { allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + reference :: !(Maybe HandleReferenceRule), + path :: !(Maybe PathReferenceRule), + condition :: !(Maybe FieldCondition), + uniqueBy :: !(Maybe Text), + hasElementFields :: !Bool, + hasObjectFields :: !Bool + } + deriving stock (Generic) + +ruleKinds :: KindSet -> PresenceList -> RuleFacts -> [RelaxationKind] +ruleKinds kinds presenceList facts = + catMaybes + [ Just Delete, + Presence <$ guard' (kinds /= LegacyKinds && presenceList == RequiredList), + ClearVocabulary <$ guard' (not (null (facts ^. #allowedValues))), + DropFormat <$ facts ^. #format, + DropUniqueBy <$ facts ^. #uniqueBy, + AllowSelf <$ guard' (any (not . (^. #allowSelf)) (facts ^. #reference)), + AllowLocal <$ guard' (any (not . (^. #allowLocal)) (facts ^. #reference)), + DropExternalUriPattern <$ (facts ^. #reference >>= (^. #externalUriPattern)) + ] + <> if kinds /= AllKinds + then [] + else + catMaybes + [ DropCardinality <$ guard' (facts ^. #cardinality /= Any), + DropCondition <$ facts ^. #condition, + DropPath <$ facts ^. #path, + DropReference <$ facts ^. #reference, + DropNested ElementFields <$ guard' (facts ^. #hasElementFields), + DropNested ObjectFields <$ guard' (facts ^. #hasObjectFields) + ] + +typeRelaxations :: KindSet -> TypeRule -> [Relaxation] +typeRelaxations kinds rule + | kinds /= AllKinds = [] + | otherwise = + map (Relaxation (TypeTarget (rule ^. #type_)) . DropTypeAttribute) . catMaybes $ + [ PathPattern <$ rule ^. #pathPattern, + ResourceScheme <$ rule ^. #resourceScheme, + RequireSchemaSection <$ guard' (rule ^. #requireSchemaSection), + SchemaColumns <$ guard' (not (null (rule ^. #schemaColumns))), + IdPrefix <$ rule ^. #idPrefix + ] + +guard' :: Bool -> Maybe () +guard' condition = if condition then Just () else Nothing + +-- | Perform one relaxation on the authored descriptor. A relaxation whose target +-- does not exist leaves the descriptor unchanged. +applyRelaxation :: Relaxation -> ProfileSpec -> ProfileSpec +applyRelaxation Relaxation {target, kind} spec = case target of + TypeTarget typeName + | kind == DropHandleIdentity -> + spec + & #types + . traverse + . filtered ((== typeName) . (^. #type_)) + %~ \rule -> + rule + & #idPrefix + .~ Nothing + & #frontmatter + %~ dropHandleFormat + | otherwise -> + spec & #types . traverse . filtered ((== typeName) . (^. #type_)) %~ relaxTypeRule kind + RuleTarget location@RuleLocation {scope} -> case scope of + ProfileScope -> spec & #frontmatter %~ relaxScope location kind + TypeScope typeName -> + spec & #types . traverse . filtered ((== typeName) . (^. #type_)) . #frontmatter %~ relaxScope location kind + where + dropHandleFormat rules = case spec ^. #idField of + Nothing -> rules + Just idField -> + foldr + (\presenceList -> presenceListOf presenceList . traverse . filtered (named idField) . #format %~ dropHandle) + rules + [RequiredList, RecommendedList, OptionalList] + dropHandle = \case + Just (DocumentHandle _) -> Nothing + other -> other + +relaxScope :: + ( HasField' "required" rules [FieldRule], + HasField' "recommended" rules [FieldRule], + HasField' "optional" rules [FieldRule] + ) => + RuleLocation -> + RelaxationKind -> + rules -> + rules +relaxScope RuleLocation {list = presenceList, field = fieldName, nested} kind rules = case nested of + Nothing -> relaxInList presenceList fieldName kind relaxFieldRule rules + Just (container, innerList, innerField) + | kind == DropUniqueKey -> + rules + & presenceListOf presenceList + . traverse + . filtered (named fieldName) + %~ \rule -> + rule + & #uniqueBy + .~ Nothing + & containerOf container + . _Just + %~ relaxInList innerList innerField Presence relaxCommon + | otherwise -> + rules + & presenceListOf presenceList + . traverse + . filtered (named fieldName) + . containerOf container + . _Just + %~ relaxInList innerList innerField kind relaxCommon + where + containerOf = \case + ElementFields -> #elementFields + ObjectFields -> #objectFields + +relaxInList :: + ( HasField' "required" rules [rule], + HasField' "recommended" rules [rule], + HasField' "optional" rules [rule], + HasField' "field" rule Text, + HasField' "when" rule (Maybe FieldCondition) + ) => + PresenceList -> + Text -> + RelaxationKind -> + (RelaxationKind -> rule -> rule) -> + rules -> + rules +relaxInList presenceList fieldName kind relaxOne rules = case kind of + Delete -> rules & presenceListOf presenceList %~ filter (not . named fieldName) + Presence + | presenceList == RequiredList -> + let demoted = [rule & field' @"when" .~ Nothing | rule <- rules ^. presenceListOf presenceList, named fieldName rule] + in rules + & presenceListOf presenceList + %~ filter (not . named fieldName) + & presenceListOf OptionalList + %~ (<> demoted) + | otherwise -> rules + _ -> rules & presenceListOf presenceList . traverse . filtered (named fieldName) %~ relaxOne kind + +presenceListOf :: + ( HasField' "required" rules [rule], + HasField' "recommended" rules [rule], + HasField' "optional" rules [rule] + ) => + PresenceList -> + Lens' rules [rule] +presenceListOf = \case + RequiredList -> field' @"required" + RecommendedList -> field' @"recommended" + OptionalList -> field' @"optional" + +named :: (HasField' "field" rule Text) => Text -> rule -> Bool +named fieldName rule = rule ^. field' @"field" == fieldName + +relaxFieldRule :: RelaxationKind -> FieldRule -> FieldRule +relaxFieldRule kind rule = case kind of + DropUniqueBy -> rule & #uniqueBy .~ Nothing + DropNested ElementFields -> rule & #elementFields .~ Nothing + DropNested ObjectFields -> rule & #objectFields .~ Nothing + DropListShape -> rule & #cardinality .~ Any & #elementFields .~ Nothing + _ -> relaxCommon kind rule + +-- | The relaxations a top-level 'FieldRule' and a nested +-- 'Okf.Profile.NestedFieldRule' share. +relaxCommon :: + ( HasField' "allowedValues" rule [Text], + HasField' "cardinality" rule Cardinality, + HasField' "format" rule (Maybe FieldFormat), + HasField' "reference" rule (Maybe HandleReferenceRule), + HasField' "path" rule (Maybe PathReferenceRule), + HasField' "when" rule (Maybe FieldCondition) + ) => + RelaxationKind -> + rule -> + rule +relaxCommon kind rule = case kind of + ClearVocabulary -> rule & field' @"allowedValues" .~ [] + AdmitValue value -> rule & field' @"allowedValues" %~ (<> [value]) + DropFormat -> rule & field' @"format" .~ Nothing + AllowSelf -> rule & field' @"reference" . _Just . #allowSelf .~ True + AllowLocal -> rule & field' @"reference" . _Just . #allowLocal .~ True + DropExternalUriPattern -> rule & field' @"reference" . _Just . #externalUriPattern .~ Nothing + DropCardinality -> rule & field' @"cardinality" .~ Any + DropCondition -> rule & field' @"when" .~ Nothing + DropPath -> rule & field' @"path" .~ Nothing + DropReference -> rule & field' @"reference" .~ Nothing + _ -> rule + +relaxTypeRule :: RelaxationKind -> TypeRule -> TypeRule +relaxTypeRule kind rule = case kind of + DropTypeAttribute PathPattern -> rule & #pathPattern .~ Nothing + DropTypeAttribute ResourceScheme -> rule & #resourceScheme .~ Nothing + DropTypeAttribute RequireSchemaSection -> rule & #requireSchemaSection .~ False + DropTypeAttribute SchemaColumns -> rule & #schemaColumns .~ [] + DropTypeAttribute IdPrefix -> rule & #idPrefix .~ Nothing + _ -> rule + +-- | What one rejection case must produce: @count@ deviation lines, at least one +-- of which contains @field@. +data CaseExpectation = CaseExpectation + { field :: !Text, + count :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | One bundle, loaded once: its concepts, file inventory, version declaration +-- and logs. +data SuiteBundle = SuiteBundle + { path :: !FilePath, + concepts :: ![Concept], + inventory :: !BundleInventory, + declaration :: !VersionDeclaration, + logs :: ![LogFile] + } + deriving stock (Generic) + +data RejectionCase = RejectionCase + { name :: !Text, + expectation :: !CaseExpectation, + bundle :: !SuiteBundle + } + deriving stock (Generic) + +-- | The acceptance bundles and the rejection cases, the cases in the order +-- @expected.json@ lists them. +data Suite = Suite + { acceptance :: ![SuiteBundle], + cases :: ![RejectionCase] + } + deriving stock (Generic) + +data SuiteError + = -- | a bundle could not be walked or its version declaration read + SuiteBundleError !FilePath !BundleError + | -- | @expected.json@ is missing or malformed (path, reason) + ExpectationsError !FilePath !Text + deriving stock (Generic, Eq, Show) + +-- | Load the acceptance bundles and the cases directory. The cases are the +-- subdirectories @expected.json@ names, in the order it names them; a +-- subdirectory it does not name is not a case. +loadSuite :: [FilePath] -> FilePath -> IO (Either SuiteError Suite) +loadSuite acceptPaths casesDir = do + let expectedPath = casesDir "expected.json" + read' <- try (LazyBytes.readFile expectedPath) + case read' of + Left (readError :: IOException) -> pure (Left (ExpectationsError expectedPath (Text.pack (show readError)))) + Right bytes -> case parseExpectations bytes of + Left reason -> pure (Left (ExpectationsError expectedPath reason)) + Right expectations -> do + accepted <- traverse loadSuiteBundle acceptPaths + rejected <- + for expectations $ \(caseName, expectation) -> + fmap (RejectionCase caseName expectation) <$> loadSuiteBundle (casesDir Text.unpack caseName) + pure (Suite <$> sequence accepted <*> sequence rejected) + +loadSuiteBundle :: FilePath -> IO (Either SuiteError SuiteBundle) +loadSuiteBundle bundlePath = do + concepts <- walkBundle bundlePath + inventory <- walkBundleInventory bundlePath + declaration <- readBundleVersion bundlePath + logs <- walkLogs bundlePath + pure . first (SuiteBundleError bundlePath) $ + SuiteBundle bundlePath <$> concepts <*> inventory <*> declaration <*> logs + +-- | Read @expected.json@: an object mapping each case name either to the field +-- name its diagnostic must contain, or to @{"field": …, "diagnostics": N}@. +-- +-- Aeson's object type does not keep key order, and the legacy witness is the +-- first case that notices, so the order is read from the token stream and the +-- values from the decoded object. A repeated key keeps its first position. +parseExpectations :: LazyBytes.ByteString -> Either Text [(Text, CaseExpectation)] +parseExpectations bytes = do + value <- first Text.pack (Aeson.eitherDecode bytes) + entries <- case value of + Aeson.Object entries -> Right entries + _ -> Left "expected a JSON object mapping case names to expectations" + order <- first Text.pack (topLevelKeys (lbsToTokens bytes)) + for (List.nub order) $ \key -> + let caseName = Key.toText key + in case KeyMap.lookup key entries of + Just (String fieldName) -> Right (caseName, CaseExpectation fieldName 1) + Just (Aeson.Object spec) + | Just (String fieldName) <- KeyMap.lookup "field" spec, + Just (Number diagnostics) <- KeyMap.lookup "diagnostics" spec, + Just count <- toBoundedInteger diagnostics, + count >= 0 -> + Right (caseName, CaseExpectation fieldName count) + _ -> + Left + ( "case " + <> caseName + <> ": expected a field name or {\"field\": …, \"diagnostics\": N}" + ) + +topLevelKeys :: Tokens k String -> Either String [Key] +topLevelKeys = \case + TkRecordOpen record -> keysOf record + TkErr err -> Left err + _ -> Left "expected a JSON object" + where + keysOf = \case + TkPair key value -> (key :) <$> (skipValue value >>= keysOf) + TkRecordEnd _ -> Right [] + TkRecordErr err -> Left err + +-- | Skip one JSON value in a token stream, returning what follows it. +skipValue :: Tokens k String -> Either String k +skipValue = \case + TkLit _ rest -> Right rest + TkText _ rest -> Right rest + TkNumber _ rest -> Right rest + TkArrayOpen items -> skipItems items + TkRecordOpen pairs -> skipPairs pairs + TkErr err -> Left err + where + skipItems = \case + TkItem value -> skipValue value >>= skipItems + TkArrayEnd rest -> Right rest + TkArrayErr err -> Left err + skipPairs = \case + TkPair _ value -> skipValue value >>= skipPairs + TkRecordEnd rest -> Right rest + TkRecordErr err -> Left err + +-- | How the CLI renders one deviation, given the compiled profile it came from +-- and the bundle's concepts. +type Render = CompiledProfile -> [Concept] -> ProfileViolation -> Text + +-- | Why a sweep cannot start: the unrelaxed profile and suite disagree. +data BaselineFault + = -- | an acceptance bundle fails core validation or has stale logs, which no + -- relaxation can change + AcceptanceCoreInvalid !FilePath ![BundleValidationError] ![LogStaleness] + | -- | an acceptance bundle deviates from the unrelaxed profile (rendered lines) + AcceptanceProfileDeviations !FilePath ![Text] + | -- | a case does not meet its expectation under the unrelaxed profile + -- (case, expectation, rendered deviation lines) + CaseExpectationUnmet !Text !CaseExpectation ![Text] + deriving stock (Generic, Eq, Show) + +-- | A suite whose baseline holds, with what every relaxation is compared to. +data PreparedSuite = PreparedSuite + { suite :: !Suite, + render :: !Render, + baseline :: !CompiledProfile, + -- | each case's violations under the unrelaxed profile, in case order + baselineViolations :: ![[ProfileViolation]], + keyOf :: !(CompiledProfile -> BehaviourKey), + baselineKey :: !BehaviourKey + } + deriving stock (Generic) + +preparedSuite :: PreparedSuite -> Suite +preparedSuite prepared = prepared ^. #suite + +preparedProfile :: PreparedSuite -> CompiledProfile +preparedProfile prepared = prepared ^. #baseline + +-- | Replace the behaviour key a prepared suite proves inertness with. For tests +-- of the inertness contradiction only: a key that erases too much makes a +-- relaxation that some case notices look inert. +withBehaviourKey :: (CompiledProfile -> BehaviourKey) -> PreparedSuite -> PreparedSuite +withBehaviourKey keyFunction prepared = + prepared & #keyOf .~ keyFunction & #baselineKey .~ keyFunction (prepared ^. #baseline) + +-- | Check the unrelaxed profile against the suite: every acceptance bundle +-- passes as @okf validate --strict --profile-enforce --log-enforce@ decides, and +-- every case meets its expectation. Reports every fault, not only the first. +checkBaseline :: Render -> CompiledProfile -> Suite -> Either (NonEmpty BaselineFault) PreparedSuite +checkBaseline renderViolation compiled suite = + case acceptanceFaults <> caseFaults of + firstFault : moreFaults -> Left (firstFault :| moreFaults) + [] -> + Right + PreparedSuite + { suite, + render = renderViolation, + baseline = compiled, + baselineViolations = caseViolations, + keyOf = behaviourKey, + baselineKey = behaviourKey compiled + } + where + acceptanceFaults = concatMap acceptanceFault (suite ^. #acceptance) + acceptanceFault bundle' + | not (null coreErrors && null staleness) = [AcceptanceCoreInvalid (bundle' ^. #path) coreErrors staleness] + | not (null violations) = [AcceptanceProfileDeviations (bundle' ^. #path) (deviationLines renderViolation compiled bundle' violations)] + | otherwise = [] + where + coreErrors = + validateBundle StrictAuthoring (bundle' ^. #declaration) (bundle' ^. #inventory) (bundle' ^. #concepts) + <> validateBundleLogs (bundle' ^. #logs) + staleness = logStaleness (bundle' ^. #concepts) (bundle' ^. #logs) + violations = profileViolations StrictAuthoring compiled bundle' + caseViolations = [profileViolations PermissiveConformance compiled (rejection ^. #bundle) | rejection <- suite ^. #cases] + caseFaults = + [ CaseExpectationUnmet (rejection ^. #name) (rejection ^. #expectation) lines' + | (rejection, violations) <- zip (suite ^. #cases) caseViolations, + let lines' = deviationLines renderViolation compiled (rejection ^. #bundle) violations, + not (meetsExpectation (rejection ^. #expectation) lines') + ] + +-- | The relaxations a sweep evaluates, in order. Outside 'LegacyKinds', an +-- @allowedValues@ relaxation that makes the descriptor invalid (a @when@ +-- condition needs the vocabulary) is followed by one @admitValue@ relaxation +-- per distinct value that some case's baseline 'ValueNotInVocabulary' violation +-- reports at that rule, so that the vocabulary can still be shown load-bearing. +planRelaxations :: KindSet -> PreparedSuite -> [Relaxation] +planRelaxations kinds prepared = + concatMap expand (enumerateRelaxations kinds spec) + where + spec = compiledProfileSpec (prepared ^. #baseline) + expand relaxation@Relaxation {target, kind} + | kinds /= LegacyKinds, + kind == ClearVocabulary, + Left _ <- compileProfile (applyRelaxation relaxation spec) = + relaxation : [Relaxation target (AdmitValue value) | value <- admissibleValues target] + | otherwise = [relaxation] + admissibleValues target = + List.nub + [ value + | (rejection, violations) <- zip (prepared ^. #suite . #cases) (prepared ^. #baselineViolations), + ValueNotInVocabulary conceptId path _ (String value) <- violations, + inScope target (conceptTypes rejection) conceptId, + pathNames path == targetPath target + ] + +-- | What one relaxation did to the suite. +data Observation = Observation + { -- | non-empty when the relaxed descriptor no longer compiles + definitionErrors :: ![ProfileDefinitionError], + -- | acceptance bundles that deviate from the relaxed profile, with their + -- rendered lines + acceptanceDeviations :: ![(FilePath, [Text])], + -- | cases that no longer meet their expectation, in legacy order: cases + -- expecting the relaxed field first, then the rest in @expected.json@ order + witnesses :: ![Text], + -- | cases in which a baseline violation of the relaxation's own kind at the + -- relaxed rule disappears, whether or not the case still fails otherwise + facetWitnesses :: ![Text], + -- | the relaxed profile compiles to the baseline's 'BehaviourKey' + behaviourUnchanged :: !Bool + } + deriving stock (Generic, Eq, Show) + +-- | The witness the Python sweep would name: the first in legacy order. +primaryWitness :: Observation -> Maybe Text +primaryWitness observation = listToMaybe (observation ^. #witnesses) + +-- | The Python sweep's verdict, with its precedence: a descriptor that does not +-- compile or an acceptance deviation is @acceptance-fails@, then the primary +-- witness, then @UNPROTECTED@. +legacyOutcome :: Observation -> Text +legacyOutcome observation + | not (null (observation ^. #definitionErrors)) = "acceptance-fails" + | not (null (observation ^. #acceptanceDeviations)) = "acceptance-fails" + | Just witness <- primaryWitness observation = "fixture " <> witness + | otherwise = "UNPROTECTED" + +-- | Apply one relaxation, recompile, and evaluate every acceptance bundle and +-- every case. All witnesses are collected, not only the first. +observeRelaxation :: PreparedSuite -> Relaxation -> Observation +observeRelaxation prepared relaxation = + case compileProfile (applyRelaxation relaxation (compiledProfileSpec (prepared ^. #baseline))) of + Left errors -> Observation (toList errors) [] [] [] False + Right compiled -> + let evaluated = + [ (rejection, before, after) + | (rejection, before) <- zip (prepared ^. #suite . #cases) (prepared ^. #baselineViolations), + let after = profileViolations PermissiveConformance compiled (rejection ^. #bundle) + ] + noticed = + [ (rejection ^. #name, rejection ^. #expectation . #field) + | (rejection, _, after) <- evaluated, + not (meetsExpectation (rejection ^. #expectation) (deviationLines renderViolation compiled (rejection ^. #bundle) after)) + ] + in Observation + { definitionErrors = [], + acceptanceDeviations = + [ (bundle' ^. #path, deviationLines renderViolation compiled bundle' violations) + | bundle' <- prepared ^. #suite . #acceptance, + let violations = profileViolations StrictAuthoring compiled bundle', + not (null violations) + ], + witnesses = map fst (legacyOrder (relaxationField relaxation) noticed), + facetWitnesses = + [ rejection ^. #name + | (rejection, before, after) <- evaluated, + any (\violation -> isFacet (conceptTypes rejection) violation && violation `notElem` after) before + ], + behaviourUnchanged = (prepared ^. #keyOf) compiled == prepared ^. #baselineKey + } + where + renderViolation = prepared ^. #render + facets = kindFacets (relaxation ^. #kind) + isFacet typesById violation = + or + [ facet `elem` facets && inScope (relaxation ^. #target) typesById conceptId && facetPathMatches facet names (targetPath (relaxation ^. #target)) + | (conceptId, facet, names) <- violationFacets violation + ] + +-- | Order (case, expected field) pairs as the Python sweep does: cases +-- expecting the given field first, the rest after, each group in +-- @expected.json@ order (a stable sort). +legacyOrder :: Text -> [(Text, Text)] -> [(Text, Text)] +legacyOrder fieldName = List.sortOn ((/= fieldName) . snd) + +conceptTypes :: RejectionCase -> Map ConceptId Text +conceptTypes rejection = Map.fromList [(conceptIdOf concept, conceptType concept) | concept <- rejection ^. #bundle . #concepts] + +inScope :: RelaxationTarget -> Map ConceptId Text -> ConceptId -> Bool +inScope target typesById conceptId = case target of + RuleTarget RuleLocation {scope = ProfileScope} -> True + RuleTarget RuleLocation {scope = TypeScope typeName} -> Map.lookup conceptId typesById == Just typeName + TypeTarget typeName -> Map.lookup conceptId typesById == Just typeName + +-- | The field names a relaxation's rule governs, outermost first; empty for a +-- type attribute. +targetPath :: RelaxationTarget -> [Text] +targetPath = \case + RuleTarget RuleLocation {field = fieldName, nested} -> fieldName : maybe [] (\(_, _, innerField) -> [innerField]) nested + TypeTarget _ -> [] + +pathNames :: FieldPath -> [Text] +pathNames (FieldPath segments) = [name' | FieldName name' <- toList segments] + +-- | Which kind of check a violation reports, so a relaxation can be credited +-- with the disappearance of exactly the checks it weakens. +data Facet + = MissingFacet + | VocabularyFacet + | FormatFacet + | UniquenessFacet + | LocalFacet + | SelfFacet + | PatternFacet + | CardinalityFacet + | ReferenceFacet + | PathFacet + | PathPatternFacet + | ResourceFacet + | SchemaSectionFacet + | SchemaColumnsFacet + | DocumentIdFacet + deriving stock (Eq, Show) + +violationFacets :: ProfileViolation -> [(ConceptId, Facet, [Text])] +violationFacets = \case + MissingProfileField conceptId key _ -> [(conceptId, MissingFacet, [key])] + MissingNestedProfileField conceptId path _ -> [(conceptId, MissingFacet, pathNames path)] + ValueNotInVocabulary conceptId path _ _ -> [(conceptId, VocabularyFacet, pathNames path)] + ValueFormatMismatch conceptId path _ _ -> [(conceptId, FormatFacet, pathNames path)] + DuplicateNestedFieldValue conceptId path _ _ -> [(conceptId, UniquenessFacet, pathNames path)] + CardinalityMismatch conceptId path _ _ -> [(conceptId, CardinalityFacet, pathNames path)] + LocalDocumentReferenceNotAllowed conceptId path _ -> reference conceptId path [LocalFacet] + SelfDocumentReference conceptId path _ -> reference conceptId path [SelfFacet, PathFacet] + ExternalReferencePatternMismatch conceptId path _ _ -> reference conceptId path [PatternFacet] + DanglingHandleReference conceptId path _ -> reference conceptId path [] + ReferenceHandlePrefixMismatch conceptId path _ _ -> reference conceptId path [] + MalformedDocumentReference conceptId path _ -> reference conceptId path [PathFacet] + ExternalReferenceSchemeNotAllowed conceptId path _ _ -> reference conceptId path [PathFacet] + MalformedPathReference conceptId path _ -> [(conceptId, PathFacet, pathNames path)] + PathEscapesBundle conceptId path _ -> [(conceptId, PathFacet, pathNames path)] + DanglingPathReference conceptId path _ -> [(conceptId, PathFacet, pathNames path)] + PathPatternMismatch conceptId _ _ -> [(conceptId, PathPatternFacet, [])] + MissingResource conceptId _ _ -> [(conceptId, ResourceFacet, [])] + ResourceSchemeMismatch conceptId _ _ -> [(conceptId, ResourceFacet, [])] + MissingSchemaSection conceptId _ -> [(conceptId, SchemaSectionFacet, [])] + SchemaColumnsMismatch conceptId _ _ _ -> [(conceptId, SchemaColumnsFacet, [])] + MissingDocumentId conceptId _ _ -> [(conceptId, DocumentIdFacet, [])] + MalformedDocumentId conceptId _ _ -> [(conceptId, DocumentIdFacet, [])] + _ -> [] + where + reference conceptId path extra = [(conceptId, facet, pathNames path) | facet <- ReferenceFacet : extra] + +kindFacets :: RelaxationKind -> [Facet] +kindFacets = \case + Delete -> [MissingFacet] + Presence -> [MissingFacet] + ClearVocabulary -> [VocabularyFacet] + AdmitValue _ -> [VocabularyFacet] + DropFormat -> [FormatFacet] + DropUniqueBy -> [UniquenessFacet] + AllowSelf -> [SelfFacet] + AllowLocal -> [LocalFacet] + DropExternalUriPattern -> [PatternFacet] + DropCardinality -> [CardinalityFacet] + DropCondition -> [MissingFacet] + DropPath -> [PathFacet] + DropReference -> [ReferenceFacet] + DropNested _ -> [] + DropTypeAttribute attribute -> case attribute of + PathPattern -> [PathPatternFacet] + ResourceScheme -> [ResourceFacet] + RequireSchemaSection -> [SchemaSectionFacet] + SchemaColumns -> [SchemaColumnsFacet] + IdPrefix -> [DocumentIdFacet] + DropListShape -> [CardinalityFacet] + DropHandleIdentity -> [DocumentIdFacet, FormatFacet] + DropUniqueKey -> [MissingFacet, UniquenessFacet] + +-- | A facet violation belongs to a rule when its field names are the rule's; +-- a uniqueness violation names the duplicated member below the list rule, and a +-- type attribute's violations name no field at all. +facetPathMatches :: Facet -> [Text] -> [Text] -> Bool +facetPathMatches facet names rulePath = case facet of + UniquenessFacet -> rulePath `List.isPrefixOf` names + _ | null rulePath -> True + _ -> names == rulePath + +profileViolations :: ValidationProfile -> CompiledProfile -> SuiteBundle -> [ProfileViolation] +profileViolations mode compiled bundle' = + validateProfileVersion (bundle' ^. #declaration) compiled + <> validateProfileWith (bundle' ^. #inventory) mode compiled (bundle' ^. #concepts) + +-- | The deviation lines @okf validate@ prints, as the catalog's harness reads +-- them: each violation is printed behind @profile: @, and a line counts when it +-- starts with that prefix and is not the advisory summary. +deviationLines :: Render -> CompiledProfile -> SuiteBundle -> [ProfileViolation] -> [Text] +deviationLines renderViolation compiled bundle' = + filter isDeviationLine . concatMap (Text.lines . ("profile: " <>) . renderViolation compiled (bundle' ^. #concepts)) + where + isDeviationLine line = + "profile: " `Text.isPrefixOf` line && not ("advisory deviation(s)" `Text.isInfixOf` line) + +meetsExpectation :: CaseExpectation -> [Text] -> Bool +meetsExpectation CaseExpectation {field = fieldName, count} lines' = + length lines' == count && any (fieldName `Text.isInfixOf`) lines' + +-- | The relaxation that weakens a whole composite policy unit of which this +-- relaxation weakens one member, per the okf-profiles catalog's ADR-9: a +-- member's effect can be masked by the unit's other members, so a member no +-- case notices is covered when some case notices the unit. +-- +-- The units are a handle @reference@ (members @allowLocal@, @allowSelf@ and +-- @externalUriPattern@), a list rule's shape (its 'List' cardinality and its +-- @elementFields@), and a type's handle identity (its @idPrefix@ and the +-- @DocumentHandle@ format of its @idField@ rule). A fourth is okf's own: a +-- list rule's @uniqueBy@ and its key member's presence, because +-- 'Okf.Profile.compileProfile' rejects a @uniqueBy@ key that is not +-- unconditionally required, so deleting or demoting the key alone never +-- compiles. +compositeUnit :: ProfileSpec -> Relaxation -> Maybe Relaxation +compositeUnit spec Relaxation {target, kind} = case (target, kind) of + (RuleTarget _, AllowLocal) -> Just (Relaxation target DropReference) + (RuleTarget _, AllowSelf) -> Just (Relaxation target DropReference) + (RuleTarget _, DropExternalUriPattern) -> Just (Relaxation target DropReference) + (RuleTarget location@RuleLocation {nested = Nothing}, DropCardinality) + | Just rule <- topLevelRule spec location, + rule ^. #cardinality == List, + isJust (rule ^. #elementFields) -> + Just (Relaxation target DropListShape) + (RuleTarget RuleLocation {nested = Nothing}, DropNested ElementFields) -> Just (Relaxation target DropListShape) + (RuleTarget location@RuleLocation {scope = TypeScope typeName, field = fieldName, nested = Nothing}, DropFormat) + | spec ^. #idField == Just fieldName, + Just rule <- topLevelRule spec location, + Just (DocumentHandle _) <- rule ^. #format, + typeHasIdPrefix typeName -> + Just (Relaxation (TypeTarget typeName) DropHandleIdentity) + (TypeTarget typeName, DropTypeAttribute IdPrefix) -> Just (Relaxation (TypeTarget typeName) DropHandleIdentity) + (RuleTarget location@RuleLocation {nested = Just (ElementFields, RequiredList, key)}, memberKind) + | memberKind == Delete || memberKind == Presence, + Just rule <- topLevelRule spec location, + rule ^. #uniqueBy == Just key -> + Just (Relaxation target DropUniqueKey) + _ -> Nothing + where + typeHasIdPrefix typeName = any (\rule -> rule ^. #type_ == typeName && isJust (rule ^. #idPrefix)) (spec ^. #types) + +topLevelRule :: ProfileSpec -> RuleLocation -> Maybe FieldRule +topLevelRule spec RuleLocation {scope, list = presenceList, field = fieldName} = + listToMaybe (filter (named fieldName) (concatMap (^. presenceListOf presenceList) scopes)) + where + scopes = case scope of + ProfileScope -> [spec ^. #frontmatter] + TypeScope typeName -> [rule ^. #frontmatter | rule <- spec ^. #types, rule ^. #type_ == typeName] + +-- | What a compiled profile makes the validator do, with what it provably never +-- consults erased, so that two compiled profiles with equal keys produce the +-- same violations on every bundle. Built from the public inspection accessors. +-- +-- The erasures, each with the function that proves it: +-- +-- * Descriptions and guidance. The validator never reads them; the CLI's +-- renderer reads a field's description only for a missing-field violation, +-- which only a rule with a presence clause produces, so a description is kept +-- exactly when the effective rule has one. +-- * A rule that constrains nothing (no presence clause, no vocabulary, 'Any' +-- cardinality, no format, nested shape, reference, path or uniqueness) in an +-- open record: 'validateProfileWith' checks a present key only against its +-- rule, and reports an undeclared key only when the record is closed. +-- * @allowSelf@ in a handle reference whose effective @allowLocal@ is 'False': +-- @validateReferenceText@ rejects every local handle before it reads +-- @allowSelf@. +-- * @externalUriPattern@ when @externalUriSchemes@ is empty: +-- @validateReferenceText@ reads the pattern only for a URI whose scheme is +-- allowed. +data BehaviourKey = BehaviourKey + { allowUnknownTypes :: !Bool, + allowUnknownFields :: !Bool, + idField :: !(Maybe Text), + requiredBundleVersion :: !(Maybe OkfVersion), + typeAttributes :: ![(Text, Maybe Text, Maybe Text, Bool, [Text], Maybe Text)], + baseRules :: !(Map Text RuleKey), + baseConstraints :: !EffectiveConceptConstraints, + typeRules :: ![(Text, Map Text RuleKey, EffectiveConceptConstraints)] + } + deriving stock (Generic, Eq, Show) + +data RuleKey = RuleKey + { presence :: ![(FieldRequirement, Maybe FieldCondition)], + description :: !(Maybe Text), + allowedValues :: ![Text], + cardinality :: !Cardinality, + format :: !(Maybe FieldFormat), + elementFields :: !(Maybe (Map Text RuleKey)), + objectFields :: !(Maybe (Map Text RuleKey)), + elementOpen :: !(Maybe Bool), + objectOpen :: !(Maybe Bool), + reference :: !(Maybe HandleReferenceRule), + path :: !(Maybe PathReferenceRule), + uniqueBy :: !(Maybe Text), + elementConstraints :: !EffectiveConceptConstraints, + objectConstraints :: !EffectiveConceptConstraints + } + deriving stock (Generic, Eq, Show) + +behaviourKey :: CompiledProfile -> BehaviourKey +behaviourKey compiled = + BehaviourKey + { allowUnknownTypes = spec ^. #allowUnknownTypes, + allowUnknownFields = open, + idField = spec ^. #idField, + requiredBundleVersion = compiledProfileRequiredBundleVersion compiled, + typeAttributes = + [ (rule ^. #type_, rule ^. #pathPattern, rule ^. #resourceScheme, rule ^. #requireSchemaSection, rule ^. #schemaColumns, rule ^. #idPrefix) + | rule <- spec ^. #types + ], + baseRules = rulesKey open (compiledProfileBaseRules compiled), + baseConstraints = compiledProfileBaseConstraints compiled, + typeRules = + [ (typeName, rulesKey open (compiledProfileRulesForType compiled typeName), compiledProfileConstraintsForType compiled typeName) + | typeName <- compiledProfileTypeNames compiled + ] + } + where + spec = compiledProfileSpec compiled + open = spec ^. #allowUnknownFields + +rulesKey :: Bool -> Map Text EffectiveFieldRule -> Map Text RuleKey +rulesKey open = Map.mapMaybe $ \rule -> + let key = ruleKey rule + in if open && constrainsNothing key then Nothing else Just key + +ruleKey :: EffectiveFieldRule -> RuleKey +ruleKey rule = + RuleKey + { presence, + description = if null presence then Nothing else fieldRuleDescription rule, + allowedValues = fieldRuleAllowedValues rule, + cardinality = fieldRuleCardinality rule, + format = fieldRuleFormat rule, + elementFields = rulesKey (elementOpen == Just True) <$> fieldRuleElementFields rule, + objectFields = rulesKey (objectOpen == Just True) <$> fieldRuleObjectFields rule, + elementOpen, + objectOpen, + reference = eraseUnread <$> fieldRuleReference rule, + path = fieldRulePath rule, + uniqueBy = fieldRuleUniqueBy rule, + elementConstraints = fieldRuleElementConstraints rule, + objectConstraints = fieldRuleObjectConstraints rule + } + where + presence = [(presenceClauseRequirement clause, presenceClauseCondition clause) | clause <- fieldRulePresenceClauses rule] + elementOpen = fieldRuleElementAllowsUnknownFields rule + objectOpen = fieldRuleObjectAllowsUnknownFields rule + eraseUnread policy = + policy + & (if policy ^. #allowLocal then id else #allowSelf .~ False) + & (if null (policy ^. #externalUriSchemes) then #externalUriPattern .~ Nothing else id) + +constrainsNothing :: RuleKey -> Bool +constrainsNothing key = + null (key ^. #presence) + && null (key ^. #allowedValues) + && key ^. #cardinality == Any + && isNothing (key ^. #format) + && isNothing (key ^. #elementFields) + && isNothing (key ^. #objectFields) + && isNothing (key ^. #reference) + && isNothing (key ^. #path) + && isNothing (key ^. #uniqueBy) + +-- | Why okf cannot decide a relaxation itself, as documented beside the cases. +data ExceptionClass + = -- | the rule is spliced from a shared family tested in its home profile + SharedFamily !Text + | -- | another rule or type attribute governs the same value + OverlappingRule !Text + | -- | a known gap, deferred to the named request (a @mori://@ URI) + Deferred !Text + deriving stock (Generic, Eq, Show) + +data SweepException = SweepException + { relaxation :: !Text, + exceptionClass :: !ExceptionClass, + rationale :: !Text + } + deriving stock (Generic, Eq, Show) + +loadExceptions :: FilePath -> IO (Either Text [SweepException]) +loadExceptions manifestPath = do + read' <- try (LazyBytes.readFile manifestPath) + pure $ case read' of + Left (readError :: IOException) -> Left (Text.pack (show readError)) + Right bytes -> parseExceptions bytes + +-- | Read an exception manifest: +-- @{"version": 1, "exceptions": [{"relaxation": ID, "class": C, …, "rationale": R}]}@. +-- The class is closed: @shared-family@ needs @home@, @overlapping-rule@ needs +-- @overlapsWith@, and @deferred@ needs @request@, a @mori://@ URI. +parseExceptions :: LazyBytes.ByteString -> Either Text [SweepException] +parseExceptions bytes = do + value <- first Text.pack (Aeson.eitherDecode bytes) + manifest <- case value of + Aeson.Object manifest -> Right manifest + _ -> Left "expected a JSON object with version and exceptions" + case KeyMap.lookup "version" manifest of + Just (Number 1) -> Right () + _ -> Left "unsupported manifest version; expected \"version\": 1" + entries <- case KeyMap.lookup "exceptions" manifest of + Just (Array entries) -> Right (toList entries) + _ -> Left "expected an \"exceptions\" array" + for (zip [0 :: Int ..] entries) $ \(entryIndex, entry) -> + first (\reason -> "exceptions[" <> Text.pack (show entryIndex) <> "]: " <> reason) $ case entry of + Aeson.Object fields -> do + relaxation <- text fields "relaxation" + rationale <- text fields "rationale" + exceptionClass <- + text fields "class" >>= \case + "shared-family" -> SharedFamily <$> text fields "home" + "overlapping-rule" -> OverlappingRule <$> text fields "overlapsWith" + "deferred" -> do + request <- text fields "request" + if "mori://" `Text.isPrefixOf` request then Right (Deferred request) else Left "request must be a mori:// URI" + other -> Left ("unknown class " <> other <> "; expected shared-family, overlapping-rule or deferred") + Right (SweepException relaxation exceptionClass rationale) + _ -> Left "expected an object" + where + text fields key = case KeyMap.lookup key fields of + Just (String value) | not (Text.null (Text.strip value)) -> Right value + _ -> Left ("missing or empty \"" <> Key.toText key <> "\"") + +-- | How one relaxation is classified. The first matching rule decides: +-- +-- 1. 'Protected': some case noticed it, and the descriptor still compiles and +-- every acceptance bundle still passes. +-- 2. 'Subsumed': a @delete@ that fails a descriptor or acceptance check, while +-- every other relaxation of the same rule is non-failing. +-- 3. 'Covered' by an @admitValue@: an @allowedValues@ relaxation the +-- descriptor cannot express, while admitting one reported value is noticed. +-- 4. 'DescriptorInvalidOutcome' or 'AcceptanceObservableOutcome'. A +-- descriptor the relaxation cannot express is first 'Covered' when its +-- composite unit is protected (rule 6), or an 'ExceptionOutcome' when the +-- manifest documents it (rule 7). +-- 5. 'Inert': the relaxed profile has the baseline's 'BehaviourKey'. +-- 6. 'Covered' by a composite unit ('compositeUnit') that is protected. +-- 7. 'ExceptionOutcome': no witness, and the manifest documents it. +-- 8. 'Unprotected'. +-- +-- 'Contradiction' is okf's own bug: a relaxation with an unchanged behaviour +-- key that some case nevertheless noticed. +data Outcome + = Protected + | Subsumed ![Text] + | -- | the covering relaxation and its witness + Covered !Text !Text + | DescriptorInvalidOutcome + | AcceptanceObservableOutcome + | Inert !Text + | ExceptionOutcome !SweepException + | Unprotected + | Contradiction + deriving stock (Generic, Eq, Show) + +outcomeName :: Outcome -> Text +outcomeName = \case + Protected -> "protected" + Subsumed _ -> "subsumed" + Covered _ _ -> "covered" + DescriptorInvalidOutcome -> "descriptor-invalid" + AcceptanceObservableOutcome -> "acceptance-observable" + Inert _ -> "inert" + ExceptionOutcome _ -> "exception" + Unprotected -> "unprotected" + Contradiction -> "contradiction" + +outcomeIsFailing :: Outcome -> Bool +outcomeIsFailing = \case + DescriptorInvalidOutcome -> True + AcceptanceObservableOutcome -> True + Unprotected -> True + Contradiction -> True + _ -> False + +data SweepResult = SweepResult + { relaxation :: !Relaxation, + observation :: !Observation, + outcome :: !Outcome + } + deriving stock (Generic, Eq, Show) + +-- | Evaluate and classify the given relaxations, normally 'planRelaxations' or +-- a filtered part of it, one rule location (or type) at a time. The list is +-- lazy per group: consuming the first group does not force later groups, and a +-- group's results, which may depend on each other, are yielded in the order +-- given. Composite units evaluated to classify a member are reported only +-- through 'Covered'. +sweepProfile :: [SweepException] -> PreparedSuite -> [Relaxation] -> [SweepResult] +sweepProfile exceptions prepared = + concatMap evaluateGroup . List.groupBy (\left right -> left ^. #target == right ^. #target) + where + spec = compiledProfileSpec (prepared ^. #baseline) + manifest = Map.fromList [(entry ^. #relaxation, entry) | entry <- exceptions] + -- Lazy maps on purpose: a delete's outcome reads its siblings' outcomes + -- from the same map, and a unit is observed only if a member asks for it. + evaluateGroup group = + let observed = LazyMap.fromList [(relaxation, observeRelaxation prepared relaxation) | relaxation <- group] + units = LazyMap.fromList [(unit, observeRelaxation prepared unit) | Just unit <- map (compositeUnit spec) group] + outcomes = LazyMap.mapWithKey classify observed + classify relaxation observation + | observation ^. #behaviourUnchanged, not (null (observation ^. #witnesses)) = Contradiction + | protects observation = Protected + | relaxation ^. #kind == Delete, + failsCheck observation, + all (nonFailing . (outcomes LazyMap.!)) siblings = + Subsumed (map relaxationId siblings) + | relaxation ^. #kind == ClearVocabulary, + not (null (observation ^. #definitionErrors)), + (admitted, witness) : _ <- + [ (sibling, witness) + | sibling@Relaxation {kind = AdmitValue _} <- siblings, + Protected <- [outcomes LazyMap.! sibling], + Just witness <- [primaryWitness (observed LazyMap.! sibling)] + ] = + Covered (relaxationId admitted) witness + | not (null (observation ^. #definitionErrors)), + Just covered <- unitCover relaxation = + covered + | not (null (observation ^. #definitionErrors)), + Just entry <- Map.lookup (relaxationId relaxation) manifest = + ExceptionOutcome entry + | not (null (observation ^. #definitionErrors)) = DescriptorInvalidOutcome + | not (null (observation ^. #acceptanceDeviations)) = AcceptanceObservableOutcome + | observation ^. #behaviourUnchanged = Inert (inertReason relaxation) + | Just covered <- unitCover relaxation = covered + | Just entry <- Map.lookup (relaxationId relaxation) manifest = ExceptionOutcome entry + | otherwise = Unprotected + where + siblings = filter (/= relaxation) group + unitCover relaxation = do + unit <- compositeUnit spec relaxation + unitObservation <- LazyMap.lookup unit units + witness <- primaryWitness unitObservation + if protects unitObservation then Just (Covered (relaxationId unit) witness) else Nothing + in [SweepResult relaxation (observed LazyMap.! relaxation) (outcomes LazyMap.! relaxation) | relaxation <- group] + protects observation = + not (null (observation ^. #witnesses)) + && null (observation ^. #definitionErrors) + && null (observation ^. #acceptanceDeviations) + failsCheck observation = + not (null (observation ^. #definitionErrors)) || not (null (observation ^. #acceptanceDeviations)) + nonFailing = \case + Protected -> True + Inert _ -> True + Covered _ _ -> True + ExceptionOutcome _ -> True + _ -> False + +inertReason :: Relaxation -> Text +inertReason Relaxation {kind} = case kind of + AllowSelf -> "allowSelf is never read while allowLocal is False" + DropExternalUriPattern -> "externalUriPattern is never read while externalUriSchemes is empty" + _ -> "the relaxed profile compiles to the same behaviour key as the baseline" + +-- | Manifest entries that no longer describe a gap: the entry's relaxation was +-- evaluated and classified as something other than an exception, or it names a +-- relaxation this run's kinds would enumerate and none was. With @onlySome@ +-- (an @--only@ run) an entry for a relaxation that was not swept is not stale. +staleExceptions :: KindSet -> Bool -> [SweepException] -> [(Text, Outcome)] -> [SweepException] +staleExceptions kinds onlySome exceptions results = + filter stale exceptions + where + outcomes = Map.fromList results + stale entry = case Map.lookup (entry ^. #relaxation) outcomes of + Just (ExceptionOutcome _) -> False + Just _ -> True + Nothing -> not onlySome && enumeratedBy (snd (Text.breakOnEnd "#" (entry ^. #relaxation))) + enumeratedBy kindName + | kindName `elem` legacyNames = True + | kindName == "presence" || "admitValue:" `Text.isPrefixOf` kindName = kinds /= LegacyKinds + | otherwise = kinds == AllKinds + legacyNames = mapMaybe legacyKindName [Delete, ClearVocabulary, DropFormat, DropUniqueBy, AllowSelf, AllowLocal, DropExternalUriPattern] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,7 +10,7 @@ import Data.List qualified as List import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes, mapMaybe, maybeToList) +import Data.Maybe (catMaybes, listToMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO @@ -41,6 +41,7 @@ import Okf.Profile.Discovery qualified as ProfileDiscovery import Okf.Profile.Documentation import Okf.Profile.Registry +import Okf.Profile.Sweep qualified as Sweep import Okf.Query import Okf.Trust import Okf.Validation @@ -164,6 +165,17 @@ testIO "loadProfileFile decodes the postgresql fixture" testLoadProfileFixture, testIO "loadProfileFile decodes record-completed document ID rules" testLoadDocumentIdProfileFixture, testIO "loadProfileFile exposes nested reference and uniqueness declarations" testLoadNestedReferenceProfileFixture, + testIO "sweep enumerates relaxations in declaration order" testSweepEnumeration, + testIO "sweep applies each relaxation kind to the authored descriptor" testSweepApplyRelaxation, + test "sweep reads expected.json in file order" testSweepExpectationOrder, + testIO "sweep finds witnesses and unprotected relaxations on a two-case suite" testSweepWitnesses, + testIO "sweep baseline reports a case that does not meet its expectation" testSweepBaselineFault, + testIO "sweep classifies an open profile's relaxations by evidence and proof" testSweepClassification, + testIO "sweep classifies closed-profile deletions as subsumed or acceptance-observable" testSweepClosedProfile, + testIO "sweep reports an inert relaxation some case notices as a contradiction" testSweepContradiction, + testIO "sweep applies manifest exceptions and reports stale ones" testSweepExceptions, + test "sweep rejects malformed exception manifests" testSweepMalformedExceptions, + testIO "behaviourKey erases only what validation never consults" testSweepBehaviourKeyErasures, 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, @@ -8577,3 +8589,353 @@ assertEqual (violationsFor True "stray") (unknowns coexist) assertEqual 1 (length [() | ConstraintPresenceMissing {} <- coexist]) assertEqual 1 (length [() | TimestampOrderViolation {} <- coexist]) + +-- Load-bearing sweeps --------------------------------------------------------- + +-- | A renderer that needs nothing from the CLI: 'show' names the field, which is +-- all the legacy predicate looks for. +showRender :: Sweep.Render +showRender _ _ violation = Text.pack (show violation) + +loadSweepFixture :: IO (ProfileSpec, CompiledProfile, Sweep.Suite) +loadSweepFixture = do + profilePath <- fixtureFilePath "sweep/profile.dhall" + acceptPath <- fixturePath "sweep/accept" + casesPath <- fixturePath "sweep/cases" + spec <- either (fail . Text.unpack) pure =<< loadProfileFile profilePath + compiled <- either (fail . show) pure (compileProfile spec) + suite <- either (fail . show) pure =<< Sweep.loadSuite [acceptPath] casesPath + pure (spec, compiled, suite) + +testSweepEnumeration :: IO (Either Text ()) +testSweepEnumeration = do + (spec, _, _) <- loadSweepFixture + nestedPath <- fixtureFilePath "profiles/nested-references-and-uniqueness.dhall" + nestedSpec <- either (fail . Text.unpack) pure =<< loadProfileFile nestedPath + pure $ do + assertEqual + [ "profile/required/type#delete", + "profile/required/title#delete", + "type:Note/required/status#delete", + "type:Note/required/status#allowedValues", + "type:Note/optional/summary#delete" + ] + (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.LegacyKinds spec)) + assertEqual + [ "profile/required/type#delete", + "profile/required/type#presence", + "profile/required/title#delete", + "profile/required/title#presence", + "type:Note/required/status#delete", + "type:Note/required/status#presence", + "type:Note/required/status#allowedValues", + "type:Note/optional/summary#delete" + ] + (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.DefaultKinds spec)) + assertEqual + [ "profile/required/type#delete", + "profile/required/requestId#delete", + "profile/required/requestId#format", + "profile/required/dependencies#delete", + "profile/required/dependencies/elementFields/required/ref#delete", + "profile/required/dependencies/elementFields/required/ref#allowSelf", + "profile/required/dependencies/elementFields/required/ref#allowLocal", + "profile/required/dependencies/elementFields/required/ref#externalUriPattern", + "profile/required/acceptanceCriteria#delete", + "profile/required/acceptanceCriteria#uniqueBy", + "profile/required/acceptanceCriteria/elementFields/required/id#delete", + "profile/required/acceptanceCriteria/elementFields/required/id#format", + "profile/required/acceptanceCriteria/elementFields/required/text#delete" + ] + (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.LegacyKinds nestedSpec)) + assertEqual + (Just "id") + (listToMaybe [Sweep.relaxationField r | r <- Sweep.enumerateRelaxations Sweep.LegacyKinds nestedSpec, Sweep.relaxationId r == "profile/required/acceptanceCriteria/elementFields/required/id#format"]) + +testSweepApplyRelaxation :: IO (Either Text ()) +testSweepApplyRelaxation = do + (spec, _, _) <- loadSweepFixture + nestedPath <- fixtureFilePath "profiles/nested-references-and-uniqueness.dhall" + nestedSpec <- either (fail . Text.unpack) pure =<< loadProfileFile nestedPath + let status = Sweep.RuleTarget (Sweep.RuleLocation (Sweep.TypeScope "Note") Sweep.RequiredList "status" Nothing) + note relaxed = case relaxed ^. #types of + [rule] -> Right (rule ^. #frontmatter) + other -> Left ("expected one type rule, got " <> Text.pack (show (length other))) + relax target kind = Sweep.applyRelaxation (Sweep.Relaxation target kind) + fieldsOf = map (^. #field) + ref = Sweep.RuleTarget (Sweep.RuleLocation Sweep.ProfileScope Sweep.RequiredList "dependencies" (Just (Sweep.ElementFields, Sweep.RequiredList, "ref"))) + nestedRef relaxed = do + dependencies <- lookupRawRule "dependencies" (relaxed ^. #frontmatter . #required) + case dependencies ^. #elementFields of + Just nestedRules | [member] <- nestedRules ^. #required -> Right member + _ -> Left "expected one nested rule under dependencies" + pure $ do + deleted <- note (relax status Sweep.Delete spec) + assertEqual [] (fieldsOf (deleted ^. #required)) + demoted <- note (relax status Sweep.Presence spec) + assertEqual [] (fieldsOf (demoted ^. #required)) + assertEqual ["summary", "status"] (fieldsOf (demoted ^. #optional)) + cleared <- note (relax status Sweep.ClearVocabulary spec) + assertEqual [[]] (map (^. #allowedValues) (cleared ^. #required)) + admitted <- note (relax status (Sweep.AdmitValue "wip") spec) + assertEqual [["draft", "final", "wip"]] (map (^. #allowedValues) (admitted ^. #required)) + anyShape <- note (relax status Sweep.DropCardinality spec) + assertEqual [Any] (map (^. #cardinality) (anyShape ^. #required)) + assertEqual spec (relax (Sweep.RuleTarget (Sweep.RuleLocation (Sweep.TypeScope "Missing") Sweep.RequiredList "status" Nothing)) Sweep.Delete spec) + selfAllowed <- nestedRef (relax ref Sweep.AllowSelf nestedSpec) + assertEqual (Just True) ((^. #allowSelf) <$> selfAllowed ^. #reference) + localAllowed <- nestedRef (relax ref Sweep.AllowLocal nestedSpec) + assertEqual (Just True) ((^. #allowLocal) <$> localAllowed ^. #reference) + unpatterned <- nestedRef (relax ref Sweep.DropExternalUriPattern nestedSpec) + assertEqual (Just Nothing) ((^. #externalUriPattern) <$> unpatterned ^. #reference) + unreferenced <- nestedRef (relax ref Sweep.DropReference nestedSpec) + assertEqual Nothing (unreferenced ^. #reference) + let criteria = Sweep.RuleTarget (Sweep.RuleLocation Sweep.ProfileScope Sweep.RequiredList "acceptanceCriteria" Nothing) + notUnique <- lookupRawRule "acceptanceCriteria" (relax criteria Sweep.DropUniqueBy nestedSpec ^. #frontmatter . #required) + assertEqual Nothing (notUnique ^. #uniqueBy) + flat <- lookupRawRule "acceptanceCriteria" (relax criteria (Sweep.DropNested Sweep.ElementFields) nestedSpec ^. #frontmatter . #required) + assertBool "elementFields dropped" (isNothing (flat ^. #elementFields)) + +testSweepExpectationOrder :: Either Text () +testSweepExpectationOrder = do + parsed <- + Sweep.parseExpectations + "{\"zeta\": \"status\", \"alpha\": {\"field\": \"docId\", \"diagnostics\": 2}, \"mid\": \"title\"}" + assertEqual + [ ("zeta", Sweep.CaseExpectation "status" 1), + ("alpha", Sweep.CaseExpectation "docId" 2), + ("mid", Sweep.CaseExpectation "title" 1) + ] + parsed + assertBool "a non-object is rejected" (either (const True) (const False) (Sweep.parseExpectations "[]")) + assertBool "a malformed entry is rejected" (either (const True) (const False) (Sweep.parseExpectations "{\"a\": 3}")) + +testSweepWitnesses :: IO (Either Text ()) +testSweepWitnesses = do + (_, compiled, suite) <- loadSweepFixture + pure $ do + assertEqual ["note-missing-title", "note-bad-status"] (map (^. #name) (suite ^. #cases)) + prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite) + let results = Sweep.sweepProfile [] prepared (Sweep.planRelaxations Sweep.LegacyKinds prepared) + outcomes = [(Sweep.relaxationId (r ^. #relaxation), Sweep.legacyOutcome (r ^. #observation)) | r <- results] + assertEqual + [ ("profile/required/type#delete", "UNPROTECTED"), + ("profile/required/title#delete", "fixture note-missing-title"), + ("type:Note/required/status#delete", "fixture note-bad-status"), + ("type:Note/required/status#allowedValues", "fixture note-bad-status"), + ("type:Note/optional/summary#delete", "UNPROTECTED") + ] + outcomes + +testSweepBaselineFault :: IO (Either Text ()) +testSweepBaselineFault = do + (_, compiled, suite) <- loadSweepFixture + let misdirected = + suite + & #cases + . traverse + . filtered ((== "note-bad-status") . (^. #name)) + . #expectation + . #field + .~ "title" + pure $ case Sweep.checkBaseline showRender compiled misdirected of + Left (Sweep.CaseExpectationUnmet "note-bad-status" (Sweep.CaseExpectation "title" 1) [_] :| []) -> Right () + Left faults -> Left ("unexpected faults: " <> Text.pack (show faults)) + Right _ -> Left "a case whose expected field is wrong must fail the baseline" + +lookupRawRule :: Text -> [FieldRule] -> Either Text FieldRule +lookupRawRule key rules = + case [rule | rule <- rules, rule ^. #field == key] of + [rule] -> Right rule + _ -> Left ("expected one raw rule for " <> key) + +sweepLogFile :: LogFile +sweepLogFile = LogFile "log.md" (parseLog "# Bundle Update Log\n\n## 2026-10-28\n* **Add**: Created the sweep fixture.\n") + +sweepDocument :: [(Text, Text)] -> Text +sweepDocument fields = + "---\n" <> Text.unlines [key <> ": " <> value | (key, value) <- fields] <> "---\n\n# Sweep fixture\n\nA concept.\n" + +-- | A bundle held in memory, with one fresh log so strict acceptance passes. +memoryBundle :: FilePath -> [(Text, [(Text, Text)])] -> Either Text Sweep.SuiteBundle +memoryBundle bundlePath documents = do + concepts <- for documents $ \(rawId, fields) -> do + conceptId <- parseTestConceptId rawId + document <- firstShow (parseDocument (sweepDocument fields)) + pure (conceptFromDocument conceptId document) + pure (Sweep.SuiteBundle bundlePath concepts (bundleInventoryOfConcepts concepts) VersionUndeclared [sweepLogFile]) + +memoryCase :: Text -> Text -> [(Text, Text)] -> Either Text Sweep.RejectionCase +memoryCase caseName expected fields = + Sweep.RejectionCase caseName (Sweep.CaseExpectation expected 1) <$> memoryBundle (Text.unpack caseName) [("tasks/" <> caseName, fields)] + +setSweepField :: Text -> Text -> [(Text, Text)] -> [(Text, Text)] +setSweepField key value fields = [(k, v) | (k, v) <- fields, k /= key] <> [(key, value)] + +baseTask :: [(Text, Text)] +baseTask = + [ ("type", "Task"), + ("title", "A task"), + ("description", "A task in the sweep fixture."), + ("timestamp", "\"2026-10-01T00:00:00Z\""), + ("docId", "TASK-1"), + ("status", "open") + ] + +loadCompiledFixture :: FilePath -> IO (ProfileSpec, CompiledProfile) +loadCompiledFixture name = do + path <- fixtureFilePath name + spec <- either (fail . Text.unpack) pure =<< loadProfileFile path + compiled <- either (fail . show) pure (compileProfile spec) + pure (spec, compiled) + +-- | The classification fixture's suite: one accepted task and three cases, each +-- breaking exactly one rule. +classificationSuite :: Either Text Sweep.Suite +classificationSuite = do + accept <- memoryBundle "accept" [("tasks/first", baseTask <> [("parent", "https://example.com/tasks/1")])] + cases <- + sequence + [ memoryCase "task-bad-status" "status" (setSweepField "status" "wip" baseTask), + memoryCase "task-local-parent" "parent" (baseTask <> [("parent", "TASK-9")]), + memoryCase "task-missing-closedby" "closedBy" (setSweepField "status" "done" baseTask) + ] + pure (Sweep.Suite [accept] cases) + +sweepOutcomes :: [Sweep.SweepException] -> Sweep.KindSet -> Sweep.PreparedSuite -> [(Text, Sweep.SweepResult)] +sweepOutcomes exceptions kinds prepared = + [(Sweep.relaxationId (result ^. #relaxation), result) | result <- Sweep.sweepProfile exceptions prepared (Sweep.planRelaxations kinds prepared)] + +expectOutcome :: [(Text, Sweep.SweepResult)] -> Text -> Sweep.Outcome -> Either Text () +expectOutcome results relaxation expected = + case lookup relaxation results of + Nothing -> Left ("no result for " <> relaxation <> " among " <> Text.pack (show (map fst results))) + Just result + | result ^. #outcome == expected -> Right () + | otherwise -> Left (relaxation <> ": expected " <> Text.pack (show expected) <> ", got " <> Text.pack (show (result ^. #outcome)) <> " from " <> Text.pack (show (result ^. #observation))) + +testSweepClassification :: IO (Either Text ()) +testSweepClassification = do + (_, compiled) <- loadCompiledFixture "sweep/classification.dhall" + pure $ do + suite <- classificationSuite + prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite) + let results = sweepOutcomes [] Sweep.DefaultKinds prepared + expect = expectOutcome results + -- A vocabulary a condition depends on cannot be cleared, so admitting the + -- value a case reports stands in for it. + expect "type:Task/required/status#admitValue:wip" Sweep.Protected + expect "type:Task/required/status#allowedValues" (Sweep.Covered "type:Task/required/status#admitValue:wip" "task-bad-status") + expect "type:Task/required/status#delete" Sweep.DescriptorInvalidOutcome + expect "type:Task/required/status#presence" Sweep.Unprotected + expect "type:Task/required/closedBy#delete" Sweep.Protected + expect "type:Task/required/closedBy#presence" Sweep.Protected + -- allowLocal turns the local-handle rejection into a dangling-handle one on + -- the same field, which the legacy predicate cannot tell apart. + expect "type:Task/optional/parent#allowLocal" (Sweep.Covered "type:Task/optional/parent#reference" "task-local-parent") + assertEqual (Just ["task-local-parent"]) ((^. #observation . #facetWitnesses) <$> lookup "type:Task/optional/parent#allowLocal" results) + expect "type:Task/optional/parent#allowSelf" (Sweep.Inert "allowSelf is never read while allowLocal is False") + expect "type:Task/optional/note#delete" (Sweep.Inert "the relaxed profile compiles to the same behaviour key as the baseline") + expect "type:Task/optional/priority#allowedValues" Sweep.Unprotected + assertBool "a composite unit is not reported as its own result" (isNothing (lookup "type:Task/optional/parent#reference" results)) + assertBool "no protected result lacks a witness" (and [not (null (r ^. #observation . #witnesses)) | (_, r) <- results, r ^. #outcome == Sweep.Protected]) + +testSweepClosedProfile :: IO (Either Text ()) +testSweepClosedProfile = do + (_, compiled) <- loadCompiledFixture "sweep/closed.dhall" + pure $ do + let item extra = + [("type", "Item"), ("title", "An item"), ("description", "An item."), ("timestamp", "\"2026-10-01T00:00:00Z\"")] <> extra + accept <- memoryBundle "accept" [("items/first", item [("size", "s"), ("colour", "red")])] + badSize <- memoryCase "item-bad-size" "size" (item [("size", "xl")]) + prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled (Sweep.Suite [accept] [badSize])) + let results = sweepOutcomes [] Sweep.LegacyKinds prepared + expect = expectOutcome results + expect "profile/optional/size#allowedValues" Sweep.Protected + expect "profile/optional/size#delete" (Sweep.Subsumed ["profile/optional/size#allowedValues"]) + expect "profile/optional/colour#allowedValues" Sweep.Unprotected + expect "profile/optional/colour#delete" Sweep.AcceptanceObservableOutcome + assertEqual (Just "acceptance-fails") (Sweep.legacyOutcome . (^. #observation) <$> lookup "profile/optional/size#delete" results) + +testSweepContradiction :: IO (Either Text ()) +testSweepContradiction = do + (_, compiled) <- loadCompiledFixture "sweep/classification.dhall" + pure $ do + suite <- classificationSuite + prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite) + -- A key that erases everything claims every relaxation is inert. + let erasesEverything = Sweep.withBehaviourKey (const (Sweep.behaviourKey compiled)) prepared + results = sweepOutcomes [] Sweep.DefaultKinds erasesEverything + expectOutcome results "type:Task/required/closedBy#delete" Sweep.Contradiction + +testSweepExceptions :: IO (Either Text ()) +testSweepExceptions = do + (_, compiled) <- loadCompiledFixture "sweep/classification.dhall" + pure $ do + suite <- classificationSuite + prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite) + let shared = Sweep.SweepException "type:Task/optional/priority#allowedValues" (Sweep.SharedFamily "tasks") "Tested in the tasks family." + inexpressible = Sweep.SweepException "type:Task/required/status#delete" (Sweep.OverlappingRule "type:Task/required/closedBy") "closedBy's condition needs status." + notAGap = Sweep.SweepException "type:Task/required/closedBy#delete" (Sweep.Deferred "mori://shinzui/okf/okf/improvement-requests/concepts/IR-12") "Protected after all." + absent = Sweep.SweepException "type:Task/optional/ghost#delete" (Sweep.SharedFamily "tasks") "No such rule." + exceptions = [shared, inexpressible, notAGap, absent] + results = sweepOutcomes exceptions Sweep.DefaultKinds prepared + outcomes = [(identifier, result ^. #outcome) | (identifier, result) <- results] + expectOutcome results "type:Task/optional/priority#allowedValues" (Sweep.ExceptionOutcome shared) + expectOutcome results "type:Task/required/status#delete" (Sweep.ExceptionOutcome inexpressible) + expectOutcome results "type:Task/required/closedBy#delete" Sweep.Protected + assertEqual [notAGap, absent] (Sweep.staleExceptions Sweep.DefaultKinds False exceptions outcomes) + assertEqual [notAGap] (Sweep.staleExceptions Sweep.DefaultKinds True exceptions outcomes) + -- A presence exception names a kind a legacy run never enumerates. + let presence = Sweep.SweepException "type:Task/required/ghost#presence" (Sweep.SharedFamily "tasks") "Default kinds only." + assertEqual [] (Sweep.staleExceptions Sweep.LegacyKinds False [presence] outcomes) + +testSweepMalformedExceptions :: Either Text () +testSweepMalformedExceptions = do + let rejected bytes = either (const True) (const False) (Sweep.parseExceptions bytes) + entry fields = "{\"version\": 1, \"exceptions\": [{" <> fields <> "}]}" + parsed <- Sweep.parseExceptions (entry "\"relaxation\": \"profile/required/x#delete\", \"class\": \"shared-family\", \"home\": \"okfV02\", \"rationale\": \"Spliced.\"") + assertEqual [Sweep.SweepException "profile/required/x#delete" (Sweep.SharedFamily "okfV02") "Spliced."] parsed + assertBool "version 2 is rejected" (rejected "{\"version\": 2, \"exceptions\": []}") + assertBool "an unknown class is rejected" (rejected (entry "\"relaxation\": \"r\", \"class\": \"vibes\", \"rationale\": \"x\"")) + assertBool "shared-family needs home" (rejected (entry "\"relaxation\": \"r\", \"class\": \"shared-family\", \"rationale\": \"x\"")) + assertBool "overlapping-rule needs overlapsWith" (rejected (entry "\"relaxation\": \"r\", \"class\": \"overlapping-rule\", \"rationale\": \"x\"")) + assertBool "deferred needs a mori:// request" (rejected (entry "\"relaxation\": \"r\", \"class\": \"deferred\", \"request\": \"IR-3\", \"rationale\": \"x\"")) + assertBool "an empty rationale is rejected" (rejected (entry "\"relaxation\": \"r\", \"class\": \"shared-family\", \"home\": \"h\", \"rationale\": \" \"")) + +-- | Each erasure must leave the key equal and, on concepts that exercise the +-- erased member, the violations identical; a description on a rule with a +-- presence clause must not be erased. +testSweepBehaviourKeyErasures :: IO (Either Text ()) +testSweepBehaviourKeyErasures = do + (spec, compiled) <- loadCompiledFixture "sweep/classification.dhall" + pure $ do + probes <- + traverse + (\(rawId, fields) -> conceptFromDocument <$> parseTestConceptId rawId <*> firstShow (parseDocument (sweepDocument fields))) + [ ("tasks/a", baseTask <> [("note", "anything"), ("parent", "TASK-1")]), + ("tasks/b", setSweepField "docId" "TASK-2" baseTask <> [("parent", "https://example.com/tasks/1")]), + ("tasks/c", setSweepField "docId" "TASK-3" baseTask <> [("parent", "TASK-2"), ("note", "[1, 2]")]), + ("tasks/d", [(k, v) | (k, v) <- setSweepField "docId" "TASK-4" baseTask, k /= "title"]) + ] + let onType f = spec & #types . traverse . #frontmatter %~ f + onRule name f = onType (\rules -> rules & #optional . traverse . filtered ((== name) . (^. #field)) %~ f) + withReference f = onRule "parent" (\rule -> rule & #reference . _Just %~ f) + same label relaxed = do + relaxedCompiled <- first (\errors -> label <> ": " <> Text.pack (show errors)) (compileProfile relaxed) + assertBool (label <> ": behaviour key differs") (Sweep.behaviourKey relaxedCompiled == Sweep.behaviourKey compiled) + for_ [PermissiveConformance, StrictAuthoring] $ \mode -> + assertEqual (validateProfile mode compiled probes) (validateProfile mode relaxedCompiled probes) + unpatterned = withReference (\policy -> policy & #externalUriSchemes .~ [] & #externalUriPattern .~ Nothing) + patterned = withReference (\policy -> policy & #externalUriSchemes .~ [] & #externalUriPattern ?~ "https://example[.]com/.*") + same "unconstrained optional rule in an open record" (onType (#optional %~ filter ((/= "note") . (^. #field)))) + same "description on a rule without a presence clause" (onRule "note" (#description .~ Nothing)) + same "allowSelf while allowLocal is False" (withReference (#allowSelf .~ True)) + unpatternedCompiled <- first (Text.pack . show) (compileProfile unpatterned) + patternedCompiled <- first (Text.pack . show) (compileProfile patterned) + assertBool "externalUriPattern without schemes is erased" (Sweep.behaviourKey unpatternedCompiled == Sweep.behaviourKey patternedCompiled) + for_ [PermissiveConformance, StrictAuthoring] $ \mode -> + assertEqual (validateProfile mode unpatternedCompiled probes) (validateProfile mode patternedCompiled probes) + let describedTitle = spec & #frontmatter . #required . traverse . filtered ((== "title") . (^. #field)) . #description ?~ "Shown when title is missing." + describedCompiled <- first (Text.pack . show) (compileProfile describedTitle) + assertBool "a required rule's description is kept" (Sweep.behaviourKey describedCompiled /= Sweep.behaviourKey compiled) diff --git a/test/fixtures/profile-discovery/dist-newstyle/valid-build-output.dhall b/test/fixtures/profile-discovery/dist-newstyle/valid-build-output.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profile-discovery/dist-newstyle/valid-build-output.dhall @@ -0,0 +1,2 @@ +-- Build-output directories are excluded even when they contain valid profiles. +../../profiles/decisions.dhall diff --git a/test/fixtures/sweep/accept/log.md b/test/fixtures/sweep/accept/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/accept/log.md @@ -0,0 +1,4 @@ +# Bundle Update Log + +## 2026-10-28 +* **Add**: Created the sweep fixture. diff --git a/test/fixtures/sweep/accept/notes/first.md b/test/fixtures/sweep/accept/notes/first.md new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/accept/notes/first.md @@ -0,0 +1,11 @@ +--- +type: Note +title: First +description: A note in the sweep fixture. +timestamp: "2026-10-01T00:00:00Z" +status: final +--- + +# First + +A note. diff --git a/test/fixtures/sweep/cases/expected.json b/test/fixtures/sweep/cases/expected.json new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/cases/expected.json @@ -0,0 +1,4 @@ +{ + "note-missing-title": "title", + "note-bad-status": "status" +} diff --git a/test/fixtures/sweep/cases/note-bad-status/notes/bad-status.md b/test/fixtures/sweep/cases/note-bad-status/notes/bad-status.md new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/cases/note-bad-status/notes/bad-status.md @@ -0,0 +1,11 @@ +--- +type: Note +title: Bad status +description: A note in the sweep fixture. +timestamp: "2026-10-01T00:00:00Z" +status: wip +--- + +# Bad status + +A note. diff --git a/test/fixtures/sweep/cases/note-missing-title/notes/missing-title.md b/test/fixtures/sweep/cases/note-missing-title/notes/missing-title.md new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/cases/note-missing-title/notes/missing-title.md @@ -0,0 +1,10 @@ +--- +type: Note +description: A note in the sweep fixture. +timestamp: "2026-10-01T00:00:00Z" +status: draft +--- + +# x + +A note. diff --git a/test/fixtures/sweep/classification.dhall b/test/fixtures/sweep/classification.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/classification.dhall @@ -0,0 +1,76 @@ +-- Exercises every classification rule of okf profile sweep that an open +-- profile can reach: a vocabulary a condition depends on (admitValue), a +-- local-only reference whose allowLocal is masked (covered by reference), an +-- allowSelf that is never read (inert), an unconstrained optional field +-- (inert), and an untested vocabulary (unprotected or a manifest exception). +let okf = ../../../dhall/package.dhall + +let Profile = okf.defaults.Profile + +let TypeRule = okf.defaults.TypeRule + +let FieldRule = okf.defaults.FieldRule + +let FrontmatterDefaults = okf.defaults.FrontmatterRules + +let HandleReferenceRule = okf.defaults.HandleReferenceRule + +let Cardinality = okf.Cardinality + +let FieldFormat = okf.FieldFormat + +let field = okf.mk.FieldRule + +in Profile::{ + , name = "sweep-classification" + , allowUnknownTypes = False + , idField = Some "docId" + , frontmatter = FrontmatterDefaults::{ + , required = [ field.plain "type", field.plain "title" ] + } + , types = + [ TypeRule::{ + , type = "Task" + , idPrefix = Some "TASK" + , frontmatter = FrontmatterDefaults::{ + , required = + [ FieldRule::{ + , field = "docId" + , cardinality = Cardinality.Scalar + , format = Some (FieldFormat.DocumentHandle "TASK") + } + , FieldRule::{ + , field = "status" + , allowedValues = [ "open", "done" ] + , cardinality = Cardinality.Scalar + } + , FieldRule::{ + , field = "closedBy" + , cardinality = Cardinality.Scalar + , when = Some { field = "status", hasValue = [ "done" ] } + } + ] + , optional = + [ FieldRule::{ + , field = "parent" + , cardinality = Cardinality.Scalar + , reference = Some HandleReferenceRule::{ + , localPrefix = "TASK" + , externalUriSchemes = [ "https" ] + , allowLocal = False + } + } + , FieldRule::{ + , field = "note" + , description = Some "Free text; checked by nothing." + } + , FieldRule::{ + , field = "priority" + , allowedValues = [ "low", "high" ] + , cardinality = Cardinality.Scalar + } + ] + } + } + ] + } diff --git a/test/fixtures/sweep/closed.dhall b/test/fixtures/sweep/closed.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/closed.dhall @@ -0,0 +1,35 @@ +-- A closed profile: deleting a declaration makes an accepted key unknown, which +-- the acceptance bundle notices for the wrong reason. +let okf = ../../../dhall/package.dhall + +let Profile = okf.defaults.Profile + +let FieldRule = okf.defaults.FieldRule + +let FrontmatterDefaults = okf.defaults.FrontmatterRules + +let Cardinality = okf.Cardinality + +let field = okf.mk.FieldRule + +in Profile::{ + , name = "sweep-closed" + , allowUnknownFields = False + , frontmatter = FrontmatterDefaults::{ + , required = [ field.plain "type", field.plain "title" ] + , optional = + [ field.plain "description" + , field.plain "timestamp" + , FieldRule::{ + , field = "size" + , allowedValues = [ "s", "m" ] + , cardinality = Cardinality.Scalar + } + , FieldRule::{ + , field = "colour" + , allowedValues = [ "red", "blue" ] + , cardinality = Cardinality.Scalar + } + ] + } + } diff --git a/test/fixtures/sweep/profile.dhall b/test/fixtures/sweep/profile.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/sweep/profile.dhall @@ -0,0 +1,39 @@ +-- The smallest suite a load-bearing sweep can disagree with: two cases that +-- each notice some relaxations, and rules (type, summary) that no case tests. +let okf = ../../../dhall/package.dhall + +let Profile = okf.defaults.Profile + +let TypeRule = okf.defaults.TypeRule + +let FieldRule = okf.defaults.FieldRule + +let FrontmatterDefaults = okf.defaults.FrontmatterRules + +let Cardinality = okf.Cardinality + +let field = okf.mk.FieldRule + +in Profile::{ + , name = "sweep" + , description = Some "A two-case suite for okf profile sweep." + , allowUnknownTypes = False + , frontmatter = FrontmatterDefaults::{ + , required = [ field.plain "type", field.plain "title" ] + } + , types = + [ TypeRule::{ + , type = "Note" + , frontmatter = FrontmatterDefaults::{ + , required = + [ FieldRule::{ + , field = "status" + , allowedValues = [ "draft", "final" ] + , cardinality = Cardinality.Scalar + } + ] + , optional = [ field.plain "summary" ] + } + } + ] + }