diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,26 @@ ## [Unreleased] +## [0.12.0.0] - 2026-10-28 + +### Added + +- `okf profile sweep PROFILE --accept BUNDLE --cases DIR` weakens each profile + rule one way at a time in process and reports which rejection case notices, + streaming one line (or, with `--json`, one NDJSON event) per relaxation. + `--kinds legacy` reproduces the okf-profiles Python sweep's relaxations; + the default adds presence demotion. Each relaxation is classified as + protected, subsumed, covered, inert, exception, descriptor-invalid, + acceptance-observable or unprotected, with an exception manifest + (`--exceptions`, default `CASES/sweep-exceptions.json`) for what okf cannot + decide. Exit 1 when any result is failing or an exception is stale, 2 for an + unreadable suite or a failing baseline, 3 for an inertness contradiction. + +### Changed + +- **Breaking (library):** `ProfileCommand` adds `ProfileSweep`, carrying the new + `ProfileSweepOptions`. + ## [0.11.0.0] - 2026-10-28 ### Added diff --git a/help/profiles.md b/help/profiles.md --- a/help/profiles.md +++ b/help/profiles.md @@ -8,6 +8,7 @@ USAGE okf profile init [EXPORT] --bundle DIR [--write] + okf profile sweep PROFILE.dhall --accept BUNDLE --cases DIR [--json] okf profiles okf profiles --json okf validate BUNDLE --profile PROFILE.dhall @@ -138,6 +139,73 @@ indented description line. Pass --wide to list for every value in full. The EXPORT column reads "(root)" when a registry reference is itself a profile; ID FIELD reads "-" when the profile declares no idField. + +SWEEPING RULES FOR LOAD-BEARINGNESS + + A sweep weakens each profile rule one way at a time (a relaxation) and + reports which rejection case notices. A rule no case notices is not tested. + + okf profile sweep PROFILE.dhall --accept BUNDLE --cases DIR + okf profile sweep PROFILE.dhall --accept BUNDLE --cases DIR --json + + --accept BUNDLE names a bundle that must pass validate --strict with + --profile-enforce and --log-enforce; repeat it for several. DIR holds one + case bundle per subdirectory and an expected.json mapping each case name to + the field its diagnostic must name, or to {"field": F, "diagnostics": N}. + A case meets its expectation when, validated without --strict, it prints + exactly N "profile:" lines (default 1) and one of them contains F. + + The profile is decoded once and every bundle loaded once; each relaxation + recompiles the descriptor in memory and re-runs only the profile check. If + the unrelaxed profile already fails an acceptance bundle or a case, the + sweep prints why and exits 2 before any relaxation runs. + + One line per relaxation follows as soon as its rule is decided, named by its + relaxation ID, such as type:Launch/required/launchRef#allowLocal. A + witness is a case that stops meeting its expectation. --json prints NDJSON + instead: a start event, a baseline event, one event per relaxation and a + summary. + + --kinds legacy delete, allowedValues, format, uniqueBy, allowSelf, + allowLocal, externalUriPattern + --kinds default legacy plus presence (required moved to optional) and, + for a vocabulary a condition needs, admitValue:VALUE + --kinds all default plus cardinality, condition, path, reference, + elementFields, objectFields and type attributes + --only FIELD only rules whose innermost field is FIELD, or whose + relaxation ID starts with FIELD + + Each relaxation is classified; the first that applies wins: + + protected a case noticed it; the descriptor compiles and every + acceptance bundle passes + subsumed a delete that breaks the descriptor or an acceptance + bundle, while every other relaxation of the rule passes + covered the descriptor cannot express it, or a case cannot tell + it apart, but a case notices the admitted value or the + whole policy unit (reference; list shape; idPrefix + with its document-handle format; uniqueBy with its key) + descriptor-invalid the relaxed descriptor no longer compiles + acceptance-observable an acceptance bundle fails, and no case notices + inert the relaxed profile is provably the same profile + exception documented in the exception manifest + unprotected none of the above: the suite has a gap + + --exceptions FILE (default DIR/sweep-exceptions.json when present) lists + relaxations okf cannot decide, such as members of a shared field family: + + {"version": 1, "exceptions": [{"relaxation": "ID", + "class": "shared-family", "home": "NAME", "rationale": "WHY"}]} + + class is shared-family (needs home), overlapping-rule (needs overlapsWith) + or deferred (needs request, a mori:// URI). An entry whose relaxation is not + otherwise unprotected or descriptor-invalid, or that names no relaxation + this run's kinds enumerate, is stale. + + Exit 0 when nothing is failing; 1 when a relaxation is unprotected, + descriptor-invalid or acceptance-observable, or an exception is stale; 2 + when the suite or manifest cannot be read or the baseline fails; 3 when okf + finds a relaxation inert that a case noticed, which is an okf bug. GENERATING DOCUMENTATION diff --git a/okf-cli.cabal b/okf-cli.cabal --- a/okf-cli.cabal +++ b/okf-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: okf-cli -version: 0.11.0.0 +version: 0.12.0.0 synopsis: Command-line interface for Open Knowledge Format bundles description: okf-cli provides the @okf@ executable for working with Open Knowledge Format @@ -60,6 +60,7 @@ Okf.Cli.Kit.Config Okf.Cli.Kit.Selector Okf.Cli.ProfileDiscovery + Okf.Cli.ProfileSweep Okf.Cli.Version other-modules: Paths_okf_cli @@ -80,7 +81,7 @@ generic-lens >=2.2 && <2.4, githash ^>=0.1, lens ^>=5.3, - okf-core ^>=0.11.0.0, + okf-core ^>=0.12.0.0, optparse-applicative >=0.19 && <0.20, process >=1.6 && <1.7, terminal-size >=0.3.4 && <0.4, @@ -105,7 +106,7 @@ generic-lens >=2.2 && <2.4, lens ^>=5.3, okf-cli, - okf-core ^>=0.11.0.0, + okf-core ^>=0.12.0.0, optparse-applicative >=0.19, temporary, text ^>=2.1, diff --git a/src/Okf/Cli.hs b/src/Okf/Cli.hs --- a/src/Okf/Cli.hs +++ b/src/Okf/Cli.hs @@ -24,6 +24,7 @@ ProfilesOptions (..), ProfileSourceOrigin (..), ProfileShowOptions (..), + ProfileSweepOptions (..), ResolvedProfileSource (..), RegistryTableMode (..), ReleaseVersion (..), @@ -124,6 +125,8 @@ discoverAvailableProfiles, profileSearchRootsEnvVar, ) +import Okf.Cli.ProfileSweep (ProfileSweepOptions (..), profileSweepOptionsParser, runProfileSweep) +import Okf.Cli.ProfileSweep qualified as Sweep import Okf.Cli.Version (appVersionWithGit) import Okf.ConceptId import Okf.Document @@ -395,6 +398,7 @@ | ProfileShow ProfileShowOptions | ProfileDocument ProfileDocumentOptions | ProfileInit ProfileInitOptions + | ProfileSweep ProfileSweepOptions deriving stock (Show, Eq) data ProfileListOptions = ProfileListOptions @@ -783,6 +787,12 @@ (ProfileDocument <$> profileDocumentOptionsParser <**> helper) (progDesc "Generate an OKF bundle documenting a profile") ) + <> command + "sweep" + ( info + (ProfileSweep <$> profileSweepOptionsParser <**> helper) + (progDesc "Weaken each profile rule in turn and report which rejection case notices") + ) ) <|> pure (ProfileList (ProfileListOptions [] False False False)) @@ -1184,6 +1194,7 @@ ProfileShow options -> runProfileShow options ProfileDocument options -> runProfileDocument options ProfileInit options -> runProfileInit options + ProfileSweep options -> runProfileSweepCommand options -- | Decode the plural environment value. Aeson decodes directly to @[Text]@, -- so a non-array or non-string member is rejected rather than coerced. Blank @@ -1317,6 +1328,24 @@ "Dhall expression such as a hash-pinned URL. Remote references need network access on first", "use; pass --registry with a local checkout to work offline." ] + +-- | Load and compile the profile with the same messages as every other profile +-- command, then hand over to 'runProfileSweep' with this module's renderers. +runProfileSweepCommand :: ProfileSweepOptions -> IO () +runProfileSweepCommand options = do + let path = options ^. #profilePath + spec <- loadProfileOrExit path + compiled <- compileProfileOrExit (Text.pack path) spec + runProfileSweep + Sweep.SweepRenderers + { Sweep.violation = renderProfileViolation, + Sweep.bundleValidationError = renderBundleValidationError, + Sweep.logStaleness = renderLogStaleness, + Sweep.bundleError = renderBundleError, + Sweep.definitionError = renderProfileDefinitionError + } + options + compiled runProfileList :: ProfileListOptions -> IO () runProfileList ProfileListOptions {registryRefs, noLocal, json, wide} = do diff --git a/src/Okf/Cli/ProfileSweep.hs b/src/Okf/Cli/ProfileSweep.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Cli/ProfileSweep.hs @@ -0,0 +1,370 @@ +-- | The @okf profile sweep@ command: a load-bearing sweep of one profile against +-- its acceptance bundles and rejection cases, streamed as text or NDJSON. +-- +-- The engine is 'Okf.Profile.Sweep'. This module owns the options, the output +-- formats and the exit codes; the diagnostic renderers it needs live in +-- 'Okf.Cli' and are passed in as 'SweepRenderers' so the two modules do not +-- import each other. +module Okf.Cli.ProfileSweep + ( ProfileSweepOptions (..), + SweepRenderers (..), + profileSweepOptionsParser, + runProfileSweep, + ) +where + +import Control.Exception (evaluate) +import Control.Monad (unless) +import Data.Aeson (object, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Foldable (for_, toList) +import Data.Generics.Labels () +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import GHC.Clock (getMonotonicTime) +import GHC.Conc (setNumCapabilities) +import GHC.Generics (Generic) +import Okf.Bundle (BundleError) +import Okf.Cli.Version (appVersion) +import Okf.Prelude ((^.)) +import Okf.Profile (CompiledProfile, ProfileDefinitionError, compiledProfileSpec) +import Okf.Profile.Sweep +import Okf.Validation (BundleValidationError, LogStaleness) +import Options.Applicative +import System.Directory (doesFileExist) +import System.Exit (ExitCode (..), exitWith) +import System.FilePath (()) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) +import Text.Printf (printf) + +data ProfileSweepOptions = ProfileSweepOptions + { profilePath :: !FilePath, + accept :: !(NonEmpty FilePath), + casesDir :: !FilePath, + kinds :: !KindSet, + json :: !Bool, + only :: !(Maybe Text), + -- | defaults to @CASES/sweep-exceptions.json@ when that file exists + exceptionsPath :: !(Maybe FilePath) + } + deriving stock (Generic, Show, Eq) + +-- | The CLI's renderers, so a sweep's diagnostics read exactly like +-- @okf validate@'s. +data SweepRenderers = SweepRenderers + { violation :: Render, + bundleValidationError :: BundleValidationError -> Text, + logStaleness :: LogStaleness -> Text, + bundleError :: BundleError -> Text, + definitionError :: ProfileDefinitionError -> Text + } + deriving stock (Generic) + +profileSweepOptionsParser :: Parser ProfileSweepOptions +profileSweepOptionsParser = + ProfileSweepOptions + <$> strArgument (metavar "PROFILE" <> help "Profile descriptor (.dhall) to sweep") + <*> ( NonEmpty.fromList + <$> some + ( strOption + ( long "accept" + <> metavar "BUNDLE" + <> help "Acceptance bundle that must validate strictly; repeat for several" + ) + ) + ) + <*> strOption + ( long "cases" + <> metavar "DIR" + <> help "Rejection cases: one bundle per subdirectory, named in DIR/expected.json" + ) + <*> option + (maybeReader (parseKindSet . Text.pack)) + ( long "kinds" + <> metavar "legacy|default|all" + <> value DefaultKinds + <> showDefaultWith (Text.unpack . renderKindSet) + <> help "Which relaxation kinds to evaluate" + ) + <*> switch (long "json" <> help "Emit one JSON object per line (NDJSON) instead of text") + <*> optional + ( Text.pack + <$> strOption + ( long "only" + <> metavar "FIELD" + <> help "Sweep only rules whose innermost field is FIELD, or whose relaxation ID starts with FIELD" + ) + ) + <*> optional + ( strOption + ( long "exceptions" + <> metavar "FILE" + <> help "Exception manifest; defaults to DIR/sweep-exceptions.json when it exists" + ) + ) + +-- | Every outcome the summary counts, in the order it prints them. +summaryOutcomes :: [Text] +summaryOutcomes = + ["protected", "inert", "covered", "subsumed", "exception", "unprotected", "descriptor-invalid", "acceptance-observable", "contradiction"] + +-- | Run the sweep and exit: 0 when no relaxation is failing and no exception is +-- stale, 1 when one is, 2 when the suite or manifest cannot be loaded or the +-- unrelaxed profile does not hold on the suite, and 3 when okf contradicts its +-- own inertness proof. +runProfileSweep :: SweepRenderers -> ProfileSweepOptions -> CompiledProfile -> IO () +runProfileSweep renderers options compiled = do + -- The sweep is serial, and the executable's -N makes every collection a + -- parallel one across all cores: on a busy machine that doubled the strategy + -- profile's wall time (18 s against 8.6 s with one capability). + setNumCapabilities 1 + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + started <- getMonotonicTime + manifestPath <- case options ^. #exceptionsPath of + Just explicit -> pure (Just explicit) + Nothing -> do + let conventional = (options ^. #casesDir) "sweep-exceptions.json" + present <- doesFileExist conventional + pure (if present then Just conventional else Nothing) + manifest <- traverse (\path -> (,) path <$> loadExceptions path) manifestPath + loaded <- loadSuite (toList (options ^. #accept)) (options ^. #casesDir) + let unplanned = length (selected (enumerateRelaxations (options ^. #kinds) spec)) + case (manifest, loaded) of + (Just (path, Left reason), _) -> do + emitStart Nothing unplanned + emitFault "exceptions" [Text.pack path <> ": " <> reason] + emitSummary started Nothing 2 + (_, Left suiteError) -> do + emitStart Nothing unplanned + emitFault "suite" [renderSuiteError suiteError] + emitSummary started Nothing 2 + (_, Right suite) -> case checkBaseline (renderers ^. #violation) compiled suite of + Left faults -> do + emitStart (Just (length (suite ^. #cases))) unplanned + emitFault "baseline" (concatMap renderFault (toList faults)) + emitSummary started Nothing 2 + Right prepared -> do + let exceptions = maybe [] (either (const []) id . snd) manifest + relaxations = selected (planRelaxations (options ^. #kinds) prepared) + total = length relaxations + width = maximum (0 : map (Text.length . relaxationId) relaxations) + emitStart (Just (length (suite ^. #cases))) total + baselineDone <- getMonotonicTime + emit + (object ["event" .= ("baseline" :: Text), "ok" .= True, "elapsedMs" .= milliseconds started baselineDone]) + ("baseline: ok (" <> seconds started baselineDone <> ")") + seen <- newIORef [] + previous <- newIORef baselineDone + for_ (zip [1 :: Int ..] (sweepProfile exceptions prepared relaxations)) $ \(index, result) -> do + let line = relaxationLine width index total result + _ <- evaluate (Text.length line) + now <- getMonotonicTime + before <- readIORef previous + writeIORef previous now + modifyIORef' seen ((relaxationId (result ^. #relaxation), result ^. #outcome) :) + let elapsed = milliseconds before now + emit (relaxationJson index total result elapsed) (line <> " " <> tshow elapsed <> " ms") + results <- reverse <$> readIORef seen + let stale = staleExceptions (options ^. #kinds) (isJust' (options ^. #only)) exceptions results + failing = [identifier | (identifier, outcome) <- results, outcomeIsFailing outcome] + exitCode + | any ((== Contradiction) . snd) results = 3 + | not (null failing) || not (null stale) = 1 + | otherwise = 0 + unless (options ^. #json) $ + for_ stale $ \entry -> + Text.IO.putStrLn ("stale exception: " <> entry ^. #relaxation <> " (no longer unprotected, or not swept)") + emitSummary started (Just (total, map (outcomeName . snd) results, stale, failing)) exitCode + where + spec = compiledProfileSpec compiled + selected = maybe id (\wanted -> filter (matchesOnly wanted)) (options ^. #only) + matchesOnly wanted relaxation = + relaxationField relaxation == wanted || wanted `Text.isPrefixOf` relaxationId relaxation + isJust' = maybe False (const True) + + emit :: Aeson.Value -> Text -> IO () + emit event line + | options ^. #json = LazyByteString.putStrLn (Aeson.encode event) + | otherwise = Text.IO.putStrLn line + + emitStart :: Maybe Int -> Int -> IO () + emitStart caseCount total = + emit + ( object + [ "event" .= ("start" :: Text), + "okf" .= appVersion, + "profile" .= (options ^. #profilePath), + "accept" .= toList (options ^. #accept), + "cases" .= (options ^. #casesDir), + "caseCount" .= caseCount, + "kinds" .= renderKindSet (options ^. #kinds), + "relaxationCount" .= total + ] + ) + ( "sweep: okf " + <> appVersion + <> "; profile " + <> Text.pack (options ^. #profilePath) + <> "; " + <> tshow total + <> " relaxations (" + <> renderKindSet (options ^. #kinds) + <> " kinds); " + <> maybe "cases not loaded" (\n -> tshow n <> " cases") caseCount + ) + + emitFault :: Text -> [Text] -> IO () + emitFault fault details = do + emit + (object ["event" .= ("baseline" :: Text), "ok" .= False, "fault" .= fault, "detail" .= Text.intercalate "\n" details]) + ("baseline: FAILED (" <> fault <> ")") + unless (options ^. #json) $ mapM_ (Text.IO.putStrLn . (" " <>)) details + + emitSummary :: Double -> Maybe (Int, [Text], [SweepException], [Text]) -> Int -> IO () + emitSummary started totals exitCode = do + finished <- getMonotonicTime + let (relaxationCount, outcomes, stale, failing) = fromMaybe (0, [], [], []) totals + counts = Map.fromListWith (+) ([(name', 0 :: Int) | name' <- summaryOutcomes] <> [(name', 1) | name' <- outcomes]) + emit + ( object + [ "event" .= ("summary" :: Text), + "relaxations" .= relaxationCount, + "counts" .= counts, + "staleExceptions" .= map (^. #relaxation) stale, + "failing" .= failing, + "elapsedMs" .= milliseconds started finished, + "exit" .= exitCode + ] + ) + ( "sweep: " + <> tshow relaxationCount + <> " relaxations: " + <> Text.intercalate ", " [tshow (Map.findWithDefault 0 name' counts) <> " " <> name' | name' <- summaryOutcomes, name' /= "contradiction" || Map.findWithDefault 0 name' counts > 0] + <> (if null stale then "" else "; " <> tshow (length stale) <> " stale exception(s)") + <> "; " + <> seconds started finished + ) + if exitCode == 0 then pure () else exitWith (ExitFailure exitCode) + + renderSuiteError = \case + SuiteBundleError bundlePath err -> Text.pack bundlePath <> ": " <> (renderers ^. #bundleError) err + ExpectationsError expectedPath reason -> Text.pack expectedPath <> ": " <> reason + + renderFault = \case + AcceptanceCoreInvalid bundlePath coreErrors staleness -> + ("acceptance bundle " <> Text.pack bundlePath <> " fails core validation or has stale logs:") + : map ((" " <>) . (renderers ^. #bundleValidationError)) coreErrors + <> map ((" log: " <>) . (renderers ^. #logStaleness)) staleness + AcceptanceProfileDeviations bundlePath lines' -> + ("acceptance bundle " <> Text.pack bundlePath <> " deviates from the unrelaxed profile:") + : map (" " <>) lines' + CaseExpectationUnmet caseName CaseExpectation {field = fieldName, count} lines' -> + ( "case " + <> caseName + <> " expects " + <> tshow count + <> " deviation(s) naming " + <> tshow fieldName + <> ", got " + <> tshow (length lines') + <> ":" + ) + : map (" " <>) lines' + + definitionErrorLines observation = map (renderers ^. #definitionError) (observation ^. #definitionErrors) + acceptanceLines observation = concatMap snd (observation ^. #acceptanceDeviations) + + relaxationJson index total result elapsed = + let observation = result ^. #observation + relaxation = result ^. #relaxation + outcome = result ^. #outcome + in object + [ "event" .= ("relaxation" :: Text), + "index" .= index, + "total" .= total, + "id" .= relaxationId relaxation, + "field" .= relaxationField relaxation, + "kind" .= fromMaybe (relaxationKindName (relaxation ^. #kind)) (legacyKindName (relaxation ^. #kind)), + "outcome" .= outcomeName outcome, + "legacyOutcome" .= legacyOutcome observation, + "witness" .= primaryWitness observation, + "witnesses" .= (observation ^. #witnesses), + "facetWitnesses" .= (observation ^. #facetWitnesses), + "coveredBy" .= case outcome of + Covered covering witness -> Just (object ["relaxation" .= covering, "witness" .= witness]) + _ -> Nothing, + "reason" .= outcomeReason observation outcome, + "exception" .= case outcome of + ExceptionOutcome entry -> Just (exceptionJson entry) + _ -> Nothing, + "acceptanceDeviations" .= [object ["bundle" .= bundlePath, "deviations" .= lines'] | (bundlePath, lines') <- observation ^. #acceptanceDeviations], + "definitionErrors" .= definitionErrorLines observation, + "elapsedMs" .= elapsed + ] + + outcomeReason observation = \case + Subsumed siblings -> Just ("every other relaxation of this rule is non-failing: " <> Text.intercalate ", " siblings) + Inert reason -> Just reason + DescriptorInvalidOutcome -> Just (Text.intercalate "; " (definitionErrorLines observation)) + AcceptanceObservableOutcome -> Just (Text.intercalate "; " (acceptanceLines observation)) + Contradiction -> Just "okf bug: the behaviour key is unchanged but a case noticed the relaxation" + _ -> Nothing + + exceptionJson entry = + object $ + ["relaxation" .= (entry ^. #relaxation), "rationale" .= (entry ^. #rationale)] + <> case entry ^. #exceptionClass of + SharedFamily home -> ["class" .= ("shared-family" :: Text), "home" .= home] + OverlappingRule overlapsWith -> ["class" .= ("overlapping-rule" :: Text), "overlapsWith" .= overlapsWith] + Deferred request -> ["class" .= ("deferred" :: Text), "request" .= request] + + relaxationLine width index total result = + let observation = result ^. #observation + outcome = result ^. #outcome + marker + | outcome == Contradiction = "??" + | outcomeIsFailing outcome = "!!" + | otherwise = "OK" + detail = case outcome of + Protected -> "witness " <> fromMaybe "" (primaryWitness observation) <> moreWitnesses (length (observation ^. #witnesses) - 1) + Subsumed siblings -> "subsumed by " <> tshow (length siblings) <> " non-failing sibling(s)" + Covered covering witness -> "covered by " <> covering <> " (witness " <> witness <> ")" <> facets observation + Inert reason -> "inert: " <> reason + ExceptionOutcome entry -> "exception (" <> exceptionClassName entry <> "): " <> entry ^. #rationale + other -> outcomeName other <> maybe "" (": " <>) (outcomeReason observation other) + in Text.pack (printf "[%*d/%d] " (length (show total)) index total) + <> marker + <> " " + <> Text.justifyLeft width ' ' (relaxationId (result ^. #relaxation)) + <> " " + <> detail + + facets observation = case observation ^. #facetWitnesses of + [] -> "" + cases -> "; facet witnesses " <> Text.intercalate ", " cases + + exceptionClassName entry = case entry ^. #exceptionClass of + SharedFamily _ -> "shared-family" + OverlappingRule _ -> "overlapping-rule" + Deferred _ -> "deferred" + + moreWitnesses n + | n > 0 = " (+" <> tshow n <> " more)" + | otherwise = "" + +milliseconds :: Double -> Double -> Int +milliseconds from to = round ((to - from) * 1000) + +seconds :: Double -> Double -> Text +seconds from to = Text.pack (printf "%.1f s" (to - from)) + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,7 @@ import Baikai.Provider.Claude.Interactive (claudeInteractiveCommand, defaultClaudeInteractiveConfig) import Baikai.Provider.OpenAI.Interactive (codexInteractiveCommand, defaultCodexInteractiveConfig) import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay) -import Control.Exception (AsyncException (UserInterrupt), bracket, throwTo, try) +import Control.Exception (AsyncException (UserInterrupt), bracket, finally, throwTo, try) import Control.Lens ((&), (.~), (^.)) import Control.Monad (unless) import Data.Aeson (Value (..), toJSON) @@ -21,10 +21,12 @@ import Data.List qualified as List import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..)) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) import Okf.Bundle (Concept, bundleInventoryOfConcepts, conceptAttester, conceptExecutor, conceptFromDocument, conceptIdOf, conceptParameters, conceptRuntime, conceptType, walkBundle, walkBundleInventory) import Okf.Cli import Okf.Cli.Agent.Config (AgentCommandName (..), AgentConfigSource (..), AgentField (..), AgentOverrides (..), ResolvedAgent (..), ResolvedField (..), agentSourceLabel, noAgentOverrides, parseOkfEffort, parseOkfProvider, renderAgentResolution, resolveAgent) @@ -45,13 +47,15 @@ import Okf.Index (OkfVersion (..), VersionDeclaration (..), parseOkfVersion, readBundleVersion) import Okf.Profile (Cardinality (..), CompiledProfile, FieldCondition (..), FieldFormat (..), FieldPath (..), FieldPathSegment (..), FieldRule (..), FrontmatterRules (..), HandleReferenceRule (..), NestedFieldRule (..), NestedRules (..), PathReferenceRule (..), ProfileSpec (..), ProfileViolation (..), TypeRule (..), compileProfile, compiledProfileSpec, loadProfileFile, validateProfile, validateProfileVersion) import Okf.Profile.Registry (ProfileSource (..), ProfileSourceLoadError (..), RegistryEntry (..), RegistryLoadError (..), RegistryRef (..), SourcedProfile (..), defaultRegistryReference) +import Okf.Profile.Sweep qualified as Sweep import Okf.Query (ConceptFilter (..), ConceptPredicate (..), FieldSelector (..), SortDirection (..), SortKey (..), WhereCondition (..), filterConcepts, filterConceptsWhere, parseSortKey, parseWhereCondition, sortConcepts) import Okf.Validation (ValidationProfile (..), validateBundle) import Options.Applicative -import System.Directory (Permissions (..), canonicalizePath, createDirectoryIfMissing, createFileLink, doesDirectoryExist, doesFileExist, getCurrentDirectory, getPermissions, getTemporaryDirectory, listDirectory, makeAbsolute, removeDirectoryRecursive, setModificationTime, setPermissions, withCurrentDirectory) +import System.Directory (Permissions (..), canonicalizePath, copyFile, createDirectoryIfMissing, createFileLink, doesDirectoryExist, doesFileExist, getCurrentDirectory, getPermissions, getTemporaryDirectory, listDirectory, makeAbsolute, removeDirectoryRecursive, setModificationTime, setPermissions, withCurrentDirectory) import System.Environment (getArgs, getExecutablePath, lookupEnv, setEnv, unsetEnv, withArgs) import System.Exit (ExitCode (..), exitFailure) import System.FilePath (normalise, takeDirectory, ()) +import System.IO (IOMode (..), hClose, hFlush, stdout, withFile) import System.IO.Temp (createTempDirectory) import System.Timeout (timeout) @@ -75,6 +79,7 @@ runTests :: IO () runTests = do nestedClosureCli <- testNestedClosureCli + profileSweepCli <- testProfileSweepCli productDiscoveryCli <- testProductDiscoveryCli fzfCancellation <- testFzfCancellation bundleDiscoveryListing <- testBundleDiscoveryListing @@ -128,6 +133,7 @@ nonAsciiDiagnostics <- testNonAsciiValuesSurviveDiagnostics let results = [ nestedClosureCli, + profileSweepCli, productDiscoveryCli, fzfCancellation, testHelpWrapping, @@ -3924,3 +3930,78 @@ (NestedFieldNotInProfile cid (FieldPath (FieldName "rows" :| [ArrayIndex 3, FieldName "名前"]))) == "note: nested field not declared by profile: rows[3].名前" pure (results == [Right (), Left (ExitFailure 1), Right (), Left (ExitFailure 1), Right ()] && surfaces) + +-- | Run an action with stdout redirected to a file, returning what it printed. +captureStdout :: IO a -> IO (a, Text.Text) +captureStdout action = do + temporary <- getTemporaryDirectory + directory <- createTempDirectory temporary "okf-cli-capture" + let path = directory "stdout" + result <- withFile path WriteMode $ \handle -> do + hFlush stdout + saved <- hDuplicate stdout + hDuplicateTo handle stdout + action `finally` (hFlush stdout >> hDuplicateTo saved stdout >> hClose saved) + output <- Text.IO.readFile path + removeDirectoryRecursive directory + pure (result, output) + +-- | @okf profile sweep --json@ on okf-core's two-case sweep fixture: the NDJSON +-- events arrive in order with the published keys; an untested rule exits 1 +-- until a manifest documents it, a malformed manifest exits 2, and a case whose +-- expectation is wrong stops the sweep with exit 2 before any relaxation event. +testProfileSweepCli :: IO Bool +testProfileSweepCli = withRepositoryPath2 "profile sweep CLI" "okf-core/test/fixtures/sweep/profile.dhall" "okf-core/test/fixtures/sweep" $ \descriptor fixture -> do + let sweepWith manifest casesDir = + captureStdout . try @ExitCode . runCommand . Profile . ProfileSweep $ + ProfileSweepOptions + { profilePath = descriptor, + accept = (fixture "accept") :| [], + casesDir = casesDir, + kinds = Sweep.LegacyKinds, + json = True, + only = Nothing, + exceptionsPath = manifest + } + sweep = sweepWith Nothing + events output = [event | line <- Text.lines output, Just (Aeson.Object event) <- [Aeson.decodeStrictText line]] + eventName event = KeyMap.lookup "event" event + hasKeys keys event = all (`KeyMap.member` event) keys + (completed, output) <- sweep (fixture "cases") + temporary <- getTemporaryDirectory + broken <- createTempDirectory temporary "okf-cli-sweep-broken" + createDirectoryIfMissing True (broken "note-bad-status" "notes") + copyFile (fixture "cases" "note-bad-status" "notes" "bad-status.md") (broken "note-bad-status" "notes" "bad-status.md") + Text.IO.writeFile (broken "expected.json") "{\"note-bad-status\": \"title\"}" + (faulted, faultOutput) <- sweep broken + let manifestPath = broken "manifest.json" + Text.IO.writeFile manifestPath "{\"version\": 1, \"exceptions\": [{\"relaxation\": \"profile/required/type#delete\", \"class\": \"shared-family\", \"home\": \"okfCore\", \"rationale\": \"Every profile requires type; the core suite tests it.\"}]}" + (documented, documentedOutput) <- sweepWith (Just manifestPath) (fixture "cases") + Text.IO.writeFile manifestPath "{\"version\": 1, \"exceptions\": [{\"relaxation\": \"x\", \"class\": \"vibes\", \"rationale\": \"no\"}]}" + (malformed, _) <- sweepWith (Just manifestPath) (fixture "cases") + removeDirectoryRecursive broken + let parsed = events output + relaxations = filter ((== Just "relaxation") . eventName) parsed + faultEvents = events faultOutput + outcomesOf events' = [KeyMap.lookup "outcome" event | event <- events', eventName event == Just "relaxation"] + summaryOf events' = [event | event <- events', eventName event == Just "summary"] + ok = + completed == Left (ExitFailure 1) + && outcomesOf parsed == map (Just . String) ["unprotected", "protected", "protected", "protected", "inert"] + && [KeyMap.lookup "failing" event | event <- summaryOf parsed] == [Just (toJSON ["profile/required/type#delete" :: Text.Text])] + && documented == Right () + && outcomesOf (events documentedOutput) == map (Just . String) ["exception", "protected", "protected", "protected", "inert"] + && malformed == Left (ExitFailure 2) + && map eventName parsed == map (Just . String) (["start", "baseline"] <> replicate 5 "relaxation" <> ["summary"]) + && all (hasKeys ["index", "total", "id", "field", "kind", "outcome", "legacyOutcome", "witness", "witnesses", "facetWitnesses", "coveredBy", "reason", "exception", "elapsedMs"]) relaxations + && [KeyMap.lookup "legacyOutcome" event | event <- relaxations] + == map (Just . String) ["UNPROTECTED", "fixture note-missing-title", "fixture note-bad-status", "fixture note-bad-status", "UNPROTECTED"] + && fmap (KeyMap.lookup "relaxationCount") (listToMaybe parsed) == Just (Just (Number 5)) + && faulted == Left (ExitFailure 2) + && map eventName faultEvents == map (Just . String) ["start", "baseline", "summary"] + && [KeyMap.lookup "ok" event | event <- faultEvents, eventName event == Just "baseline"] == [Just (Bool False)] + unless ok $ do + putStrLn "FAIL profile sweep CLI" + Text.IO.putStrLn output + Text.IO.putStrLn faultOutput + pure ok