diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core -version: 0.15.0.0 +version: 0.16.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. @@ -42,6 +42,7 @@ Seihou.Composition.Resolve Seihou.Core.AgentPrompt Seihou.Core.Application + Seihou.Core.ArtifactFiles Seihou.Core.ArtifactIdentity Seihou.Core.ArtifactOriginDetect Seihou.Core.ArtifactRef @@ -52,6 +53,9 @@ Seihou.Core.Context Seihou.Core.Expr Seihou.Core.Install + Seihou.Core.Judgement + Seihou.Core.JudgementExamples + Seihou.Core.JudgementState Seihou.Core.Migration Seihou.Core.Module Seihou.Core.Path @@ -115,6 +119,7 @@ Seihou.Interaction.Prompt Seihou.Manifest.Hash Seihou.Manifest.JSON + Seihou.Manifest.Judgement Seihou.Manifest.Types Seihou.Manifest.Upgrade Seihou.Prelude @@ -174,9 +179,12 @@ Seihou.Core.EntailmentSpec Seihou.Core.ExprSpec Seihou.Core.InstallSpec + Seihou.Core.JudgementArtifactSpec + Seihou.Core.JudgementSpec Seihou.Core.ListSpec Seihou.Core.MigrationSpec Seihou.Core.ModuleSpec + Seihou.Core.PathSpec Seihou.Core.RecipeSpec Seihou.Core.RegistryEmitSpec Seihou.Core.RegistrySpec diff --git a/src/Seihou/Composition/RecipeChain.hs b/src/Seihou/Composition/RecipeChain.hs --- a/src/Seihou/Composition/RecipeChain.hs +++ b/src/Seihou/Composition/RecipeChain.hs @@ -10,7 +10,8 @@ import Data.Text qualified as T import Seihou.Composition.Recipe import Seihou.Composition.Resolve (verifyDependencySources) -import Seihou.Core.ArtifactIdentity (normalizeOriginUrl, sameArtifactIdentity) +import Seihou.Core.ArtifactFiles (renderAmbiguousArtifact) +import Seihou.Core.ArtifactIdentity (sameArtifactIdentity, sameRepositoryOrigin) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin, readOriginInfo) import Seihou.Core.Module (discoverModule, discoverRunnable) import Seihou.Core.Recipe (validateRecipe, validateRecipeVersion) @@ -55,7 +56,7 @@ Nothing -> pure () Just required -> do actual <- liftIO (readOriginInfo baseDir) - unless (maybe False (\info -> normalizeOriginUrl (info ^. #sourceUrl) == normalizeOriginUrl required) actual) $ + unless (maybe False (\info -> sameRepositoryOrigin (info ^. #sourceUrl) required) actual) $ failure ("Base '" <> ref ^. #recipe . #unRecipeName <> "' requires " <> required <> "; resolved origin is different or unknown") case validateRecipeVersion ref base of Left errors -> failure ("Base '" <> ref ^. #recipe . #unRecipeName <> "' from " <> maybe "local discovery" id (ref ^. #source) <> ": " <> T.intercalate "; " errors) @@ -78,6 +79,7 @@ describe (CircularDependency names) = "Dependency cycle: " <> T.intercalate " -> " [name | ModuleName name <- names] describe (MissingSourceFile (ModuleName name) path) = "Member '" <> name <> "' is missing " <> T.pack path describe (RegistryEvalError source reason) = "Cannot evaluate registry '" <> source <> "': " <> reason +describe (AmbiguousArtifact name dir files) = renderAmbiguousArtifact name dir files -- | Descriptor evidence is normalized Dhall, independent of import/cache paths. recordRecipeChain :: ExpandedRecipe -> IO [AppliedRecipeNode] diff --git a/src/Seihou/Composition/Resolve.hs b/src/Seihou/Composition/Resolve.hs --- a/src/Seihou/Composition/Resolve.hs +++ b/src/Seihou/Composition/Resolve.hs @@ -27,7 +27,7 @@ import Data.Text qualified as T import Seihou.Composition.Graph (buildGraph, topoSort) import Seihou.Composition.Instance (ModuleInstance (..), mkInstance, primaryInstance) -import Seihou.Core.ArtifactIdentity (normalizeOriginUrl) +import Seihou.Core.ArtifactIdentity (sameRepositoryOrigin) import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo) import Seihou.Core.Module (discoverModule, validateModule) import Seihou.Core.Types @@ -593,7 +593,7 @@ let name = dep ^. #module_ dir <- ExceptT (discoverModule paths name) actual <- liftIO (readOriginInfo dir) - unless (maybe False (\info -> normalizeOriginUrl (info ^. #sourceUrl) == normalizeOriginUrl required) actual) $ + unless (maybe False (\info -> sameRepositoryOrigin (info ^. #sourceUrl) required) actual) $ ExceptT $ pure $ Left $ diff --git a/src/Seihou/Core/ArtifactFiles.hs b/src/Seihou/Core/ArtifactFiles.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/ArtifactFiles.hs @@ -0,0 +1,53 @@ +-- | The definition files that identify an artifact directory's kind, and the +-- ambiguity rule introduced with judgements. +-- +-- Before judgements, a directory holding several definition files resolved by +-- a fixed precedence (module > recipe > blueprint > prompt). Judgements do not +-- join that precedence: a @judgement.dhall@ that shares its directory with any +-- other definition file is reported as ambiguous instead of being silently +-- hidden by, or silently hiding, the other artifact. +module Seihou.Core.ArtifactFiles + ( definitionFiles, + presentDefinitionFiles, + judgementAmbiguity, + renderAmbiguousArtifact, + ) +where + +import Control.Monad (filterM) +import Data.Generics.Labels () +import Data.Text qualified as T +import Seihou.Core.Types (ModuleName (..)) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Every artifact definition file, in the historical precedence order. +definitionFiles :: [FilePath] +definitionFiles = ["module.dhall", "recipe.dhall", "blueprint.dhall", "prompt.dhall", "judgement.dhall"] + +-- | The definition files present directly in a directory, in 'definitionFiles' +-- order. +presentDefinitionFiles :: FilePath -> IO [FilePath] +presentDefinitionFiles dir = filterM (doesFileExist . (dir )) definitionFiles + +-- | @Just files@ when the directory holds a @judgement.dhall@ together with at +-- least one other definition file; 'Nothing' otherwise. Combinations that do +-- not involve a judgement keep their existing precedence and are not reported. +judgementAmbiguity :: FilePath -> IO (Maybe [FilePath]) +judgementAmbiguity dir = do + present <- presentDefinitionFiles dir + pure $ + if "judgement.dhall" `elem` present && length present > 1 + then Just present + else Nothing + +-- | One-line diagnostic for an ambiguous artifact directory. +renderAmbiguousArtifact :: ModuleName -> FilePath -> [FilePath] -> Text +renderAmbiguousArtifact name dir files = + "ambiguous artifact '" + <> name ^. #unModuleName + <> "' at " + <> T.pack dir + <> ": it contains " + <> T.intercalate ", " (map T.pack files) + <> "; an artifact directory must hold exactly one definition file" diff --git a/src/Seihou/Core/ArtifactIdentity.hs b/src/Seihou/Core/ArtifactIdentity.hs --- a/src/Seihou/Core/ArtifactIdentity.hs +++ b/src/Seihou/Core/ArtifactIdentity.hs @@ -18,14 +18,18 @@ -- not, with no unverifiable middle ground. module Seihou.Core.ArtifactIdentity ( sameArtifactIdentity, + sameRepositoryOrigin, + RepositoryOriginKey, + repositoryOriginKey, normalizeOriginUrl, normalizeProjectPath, isMachineLocalOriginUrl, ) where -import Data.Char (isAsciiLower, isAsciiUpper) -import Data.Maybe (fromMaybe) +import Control.Monad (guard) +import Data.Char (isAsciiLower, isAsciiUpper, isControl, isDigit, isHexDigit, isSpace) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text qualified as T import Seihou.Core.Types (ArtifactOrigin (..)) import Seihou.Prelude @@ -34,8 +38,9 @@ -- -- Two origins of different kinds are never the same artifact. Within a kind -- the comparison is structural, after normalising away spellings that differ --- without meaning anything: a trailing @.git@ on a git URL, and a @.\/@ --- prefix or trailing slash on a project-relative path. +-- without meaning anything: remote URLs are compared with +-- 'sameRepositoryOrigin', and project-relative paths ignore a @.\/@ prefix +-- and trailing slashes. -- -- A 'LocalOrigin' carries no provenance at all, so two of them compare equal -- exactly when they carry the same name. That is deliberately weak — it is @@ -45,30 +50,213 @@ sameArtifactIdentity :: ArtifactOrigin -> ArtifactOrigin -> Bool sameArtifactIdentity left right = case (left, right) of (RemoteOrigin leftUrl leftName _, RemoteOrigin rightUrl rightName _) -> - normalizeOriginUrl leftUrl == normalizeOriginUrl rightUrl + sameRepositoryOrigin leftUrl rightUrl && leftName == rightName (ProjectOrigin leftPath, ProjectOrigin rightPath) -> normalizeProjectPath leftPath == normalizeProjectPath rightPath (LocalOrigin leftName, LocalOrigin rightName) -> leftName == rightName _ -> False --- | Reduce a git URL to a form two spellings of the same repository share. +-- | Reduce a git URL to a form two spellings of the same repository share, +-- lexically. -- -- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and --- @https:\/\/host\/repo\/@ all name the same repository, and a manifest --- written by a developer who typed one of them must not read as a different --- artifact to a developer who typed another. Public GitHub SSH spellings also --- normalize to HTTPS; no equivalence is inferred for other hosts or paths. +-- @https:\/\/host\/repo\/@ all reduce to one text. This is a cosmetic +-- helper for keys that must stay specific to one connection method — a +-- session clone cache, the grouping of machine-local paths during repair — +-- and it never equates two transports. Identity decisions use +-- 'sameRepositoryOrigin' or 'repositoryOriginKey' instead. Never use the +-- result as a clone URL. normalizeOriginUrl :: Text -> Text -normalizeOriginUrl = - dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . githubTransport . T.strip +normalizeOriginUrl = cosmeticPath . T.strip + +-- | Trailing slashes and at most one terminal @.git@ of a non-empty final +-- component, so @repo\/.git@ keeps its separate @.git@ component. +cosmeticPath :: Text -> Text +cosmeticPath path = + let trimmed = dropTrailingSlashes path + in case T.stripSuffix ".git" trimmed of + Just base | not (T.null base), T.last base /= '/' -> dropTrailingSlashes base + _ -> trimmed where - githubTransport url - | Just path <- T.stripPrefix "git@github.com:" url = "https://github.com/" <> path - | Just path <- T.stripPrefix "ssh://git@github.com/" url = "https://github.com/" <> path - | otherwise = url dropTrailingSlashes = T.dropWhileEnd (== '/') - dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url) + +-- | Whether two recorded git URLs name the same repository. +-- +-- This is the one repository-identity comparison seihou makes: the manifest +-- guard, install collision checks, migration receipts, repair evidence and +-- update staging all ask it. The recorded text is never rewritten; this only +-- answers the question. See 'repositoryOriginKey' for the rules. +sameRepositoryOrigin :: Text -> Text -> Bool +sameRepositoryOrigin left right = repositoryOriginKey left == repositoryOriginKey right + +-- | The repository a recorded git URL identifies, as an opaque comparable +-- key. Two URLs have equal keys exactly when 'sameRepositoryOrigin' says +-- they name the same repository, so the key can index a map. +-- +-- The constructors are private. Their distinct tags keep classes apart: a +-- recognised public GitHub repository, a generic scheme URL, a generic +-- scp-style address, and opaque text (local paths, @file:@, unsupported +-- schemes, and anything malformed) can never compare equal to one another. +data RepositoryOriginKey + = -- | Owner and repository on public GitHub. + GitHubRepository !Text !Text + | -- | Scheme, user information, host, non-default port, path, query and + -- fragment of a generic network URL. Absent and empty query or + -- fragment differ. + SchemeEndpoint !Text !(Maybe Text) !Text !(Maybe Int) !Text !(Maybe Text) !(Maybe Text) + | -- | User, host and path of a generic scp-style address. A relative path + -- may be relative to the user's home and is kept as written. + ScpEndpoint !(Maybe Text) !Text !Text + | -- | Text no supported form recognised, after cosmetic normalisation. + OpaqueOrigin !Text + deriving stock (Eq, Ord, Show, Generic) + +-- | Parse a recorded git URL into its 'RepositoryOriginKey'. Total, pure and +-- offline: no DNS, filesystem, git configuration or network. +-- +-- The text is parsed before anything is normalised, so cleanup can never +-- manufacture a match. Public GitHub has one documented equivalence class: +-- @https:\/\/github.com\/OWNER\/REPO@ (port 443 allowed, user information +-- ignored), @ssh:\/\/git\@github.com\/OWNER\/REPO@ (port 22 allowed), +-- @git\@github.com:OWNER\/REPO@, and @ssh:\/\/git\@ssh.github.com:443\/OWNER\/REPO@, +-- each with an optional terminal @.git@ and trailing slashes. The path must be +-- exactly two ordinary components with no query, fragment, escape or empty +-- segment. Everything else compares conservatively: generic URLs keep their +-- scheme, user, non-default port, path, query and fragment; scp-style +-- addresses keep their user and relative path and never equal a scheme URL. +repositoryOriginKey :: Text -> RepositoryOriginKey +repositoryOriginKey raw + | T.any (\c -> isSpace c || isControl c) url = opaque + | isMachineLocalOriginUrl url = opaque + | (scheme, rest) <- T.breakOn "://" url, + not (T.null rest) = + fromMaybe opaque (parseSchemeUrl (T.toLower scheme) (T.drop 3 rest)) + | otherwise = fromMaybe opaque (parseScp url) + where + url = T.strip raw + opaque = OpaqueOrigin (normalizeOriginUrl url) + +parseSchemeUrl :: Text -> Text -> Maybe RepositoryOriginKey +parseSchemeUrl scheme rest = do + defaultPort <- lookup scheme [("https", 443), ("http", 80), ("ssh", 22), ("git", 9418)] + let (beforeFragment, fragment) = splitDelimiter '#' rest + (beforeQuery, query) = splitDelimiter '?' beforeFragment + (authority, path) = T.break (== '/') beforeQuery + (user, hostPort) <- case T.splitOn "@" authority of + [hostPort] -> Just (Nothing, hostPort) + [user, hostPort] -> Just (Just user, hostPort) + _ -> Nothing + (host, port) <- parseHostPort hostPort + let explicitPort = if port == Just defaultPort then Nothing else port + generic = do + let cleaned = cosmeticPath path + if T.null cleaned + then Nothing + else Just (SchemeEndpoint scheme user host explicitPort cleaned query fragment) + github = do + guard (isNothing query && isNothing fragment) + guard $ case (scheme, user, host, port) of + ("https", _, "github.com", Nothing) -> True + ("https", _, "github.com", Just 443) -> True + ("ssh", Just "git", "github.com", Nothing) -> True + ("ssh", Just "git", "github.com", Just 22) -> True + ("ssh", Just "git", "ssh.github.com", Just 443) -> True + _ -> False + githubPath =<< T.stripPrefix "/" path + maybe generic Just github + +-- | Split at the first delimiter, keeping an empty value distinct from an +-- absent delimiter. +splitDelimiter :: Char -> Text -> (Text, Maybe Text) +splitDelimiter delimiter text = case T.break (== delimiter) text of + (before, after) + | T.null after -> (before, Nothing) + | otherwise -> (before, Just (T.drop 1 after)) + +-- | A lowercased DNS host or bracketed IPv6 literal, and an optional port in +-- 1..65535. An empty or out-of-range port is malformed. +parseHostPort :: Text -> Maybe (Text, Maybe Int) +parseHostPort text = do + (host, portPart) <- + if "[" `T.isPrefixOf` text + then case T.breakOn "]" text of + (_, close) | T.null close -> Nothing + (open, close) -> do + let literal = T.drop 1 open + guard (not (T.null literal) && T.all (\c -> isHexDigit c || c == ':' || c == '.') literal) + Just (T.toLower (open <> "]"), T.drop 1 close) + else do + let (name, portPart) = T.break (== ':') text + guard (validDnsHost name) + Just (T.toLower name, portPart) + port <- case T.uncons portPart of + Nothing -> Just Nothing + Just (':', digits) -> Just <$> parsePort digits + Just _ -> Nothing + Just (host, port) + +parsePort :: Text -> Maybe Int +parsePort digits = do + guard (not (T.null digits) && T.length digits <= 5 && T.all isDigit digits) + let value = T.foldl' (\acc c -> acc * 10 + fromEnum c - fromEnum '0') 0 digits + guard (value >= 1 && value <= 65535) + Just value + +validDnsHost :: Text -> Bool +validDnsHost name = + not (T.null name) + && T.all (\c -> isAsciiLower c || isAsciiUpper c || isDigit c || c == '-' || c == '.') name + && not ("." `T.isPrefixOf` name) + && not (".." `T.isInfixOf` name) + +-- | Git's scp-like syntax, @[user\@]host:path@, recognised only when no +-- slash precedes the first colon. Local and Windows paths were excluded +-- before this is tried. +parseScp :: Text -> Maybe RepositoryOriginKey +parseScp text = do + let (beforeColon, afterColon) = T.break (== ':') text + guard (not (T.null afterColon) && not ("/" `T.isInfixOf` beforeColon)) + (user, rest) <- case T.break (== '@') text of + (candidate, at) + | not (T.null at), + T.all (\c -> c /= ':' && c /= '/' && c /= '[') candidate -> + if T.null candidate then Nothing else Just (Just candidate, T.drop 1 at) + _ -> Just (Nothing, text) + (hostPart, path) <- splitHost rest + (host, port) <- parseHostPort hostPart + let cleaned = cosmeticPath path + guard (isNothing port && not (T.null cleaned)) + -- A one-letter host with no user is a drive designator, not a server. + guard (isJust user || T.length host > 1) + let github = do + guard (user == Just "git" && host == "github.com") + githubPath path + maybe (Just (ScpEndpoint user host cleaned)) Just github + where + splitHost rest + | "[" `T.isPrefixOf` rest = case T.breakOn "]:" rest of + (_, close) | T.null close -> Nothing + (open, close) -> Just (open <> "]", T.drop 2 close) + | otherwise = case T.break (== ':') rest of + (host, colonPath) | not (T.null colonPath) -> Just (host, T.drop 1 colonPath) + _ -> Nothing + +-- | @OWNER\/REPO@ with optional trailing slashes and at most one terminal +-- @.git@, both components ordinary ASCII names. Case is preserved. +githubPath :: Text -> Maybe RepositoryOriginKey +githubPath path = case T.splitOn "/" (T.dropWhileEnd (== '/') path) of + [owner, repoWithSuffix] -> do + let repo = fromMaybe repoWithSuffix (T.stripSuffix ".git" repoWithSuffix) + guard (ordinaryComponent owner && ordinaryComponent repo) + Just (GitHubRepository owner repo) + _ -> Nothing + where + ordinaryComponent component = + not (T.null component) + && component /= "." + && component /= ".." + && T.all (\c -> isAsciiLower c || isAsciiUpper c || isDigit c || c == '-' || c == '_' || c == '.') component -- | Reduce a project-relative path to a comparable form. The manifest stores -- these with forward slashes; @.\/@ prefixes and trailing slashes are noise. diff --git a/src/Seihou/Core/Judgement.hs b/src/Seihou/Core/Judgement.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Judgement.hs @@ -0,0 +1,758 @@ +-- | The domain of judgements: author-defined yes/no checks over captured +-- evidence, and the deterministic project policy that turns model-reported +-- evidence into a decision. +-- +-- A judgement is a list of checks. Each check is one question about the +-- evidence, with a declared concern direction (whether a yes or a no answer is +-- the concern), its own enforcement, and its own threshold band for the +-- generative review and, separately, for an optional judgment-only gate. +-- +-- Every probability in this module is the probability of the /concern/, +-- already converted from the model's probability of yes by +-- 'concernProbability'. A higher number is always worse, whichever answer the +-- concern is, so the policy functions never consult the concern direction. +-- +-- Nothing in this module refers to secrets or security: the secret scan is one +-- member of the closed set of deterministic checks, and scanner results reach +-- the policy only as deterministic findings. +-- +-- This module is pure and knows nothing about Shikumi, provider transports or +-- Git. The runtime adapter in seihou-cli converts provider replies into the +-- observation types below; 'decideCheck' and 'decideJudgement' then decide. +module Seihou.Core.Judgement + ( -- * Definitions + JudgementDefinition (..), + JudgementRef (..), + JudgementCheck (..), + Answer (..), + Enforcement (..), + Thresholds (..), + Severity (..), + FindingCategory (..), + EvidenceDeclaration (..), + EvidenceScopeKind (..), + CoverageLimits (..), + DeterministicCheck (..), + defaultCoverageLimits, + defaultEvidenceDeclaration, + renderAnswer, + renderEnforcement, + renderSeverity, + renderDeterministicCheck, + renderScopeKind, + + -- * Validation + JudgementError (..), + judgementError, + validateDefinition, + validateThresholds, + + -- * Policy + DataPolicy (..), + renderDataPolicy, + JudgementPolicy (..), + CheckPolicy (..), + defaultPolicy, + checkPolicyFor, + + -- * Probabilities + concernProbability, + validProbability, + renderProbability, + + -- * Observations + Location (..), + Finding (..), + DeterministicFinding (..), + ReviewObservation (..), + GateObservation (..), + ChunkObservation (..), + CheckObservation (..), + Coverage (..), + JudgementObservation (..), + + -- * Output validation + EvidenceIndex (..), + RawFinding (..), + RawReview (..), + validateReview, + findingBlocks, + + -- * Decisions + CheckStatus (..), + renderCheckStatus, + DecidedBy (..), + DecisionReason (..), + renderDecisionReason, + ChunkDecision (..), + CheckDecision (..), + JudgementStatus (..), + renderJudgementStatus, + JudgementDecision (..), + decideChunk, + decideCheck, + decideJudgement, + statusSeverity, + ) +where + +import Control.Monad (forM_, unless, when) +import Data.Foldable (toList) +import Data.Generics.Labels () +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (Down (..)) +import Data.Text qualified as T +import Seihou.Prelude + +-- --------------------------------------------------------------------------- +-- Definitions + +-- | Which answer to a check's question is the concern. +data Answer = Yes | No + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderAnswer :: Answer -> Text +renderAnswer Yes = "yes" +renderAnswer No = "no" + +-- | Whether a check's outcome can prevent the gated action. +data Enforcement = Enforced | Advisory + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderEnforcement :: Enforcement -> Text +renderEnforcement Enforced = "enforced" +renderEnforcement Advisory = "advisory" + +-- | A threshold band over the probability of the concern. At or above +-- 'blockAt' the check blocks; at or below 'passAt' it may pass; in between it +-- needs human review. Equal values remove the needs-review band. +data Thresholds = Thresholds + { blockAt :: !Double, + passAt :: !Double + } + deriving stock (Eq, Show, Generic) + +-- | Declared severity of a finding category, least severe first. +data Severity = Info | Low | Medium | High | Critical + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderSeverity :: Severity -> Text +renderSeverity = \case + Info -> "info" + Low -> "low" + Medium -> "medium" + High -> "high" + Critical -> "critical" + +-- | A category a check's findings may use. The model names the category; the +-- severity is the author's, never the model's. +data FindingCategory = FindingCategory + { name :: !Text, + severity :: !Severity, + description :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- | The closed, versioned set of evidence scopes in this delivery. +data EvidenceScopeKind = StagedChangesScope | CommitRangeScope + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderScopeKind :: EvidenceScopeKind -> Text +renderScopeKind StagedChangesScope = "staged-changes" +renderScopeKind CommitRangeScope = "commit-range" + +-- | Which evidence a judgement may inspect. Path patterns are Git-style +-- globs relative to the project root; an empty include list means every path. +data EvidenceDeclaration = EvidenceDeclaration + { scopes :: ![EvidenceScopeKind], + include :: ![Text], + exclude :: ![Text] + } + deriving stock (Eq, Show, Generic) + +defaultEvidenceDeclaration :: EvidenceDeclaration +defaultEvidenceDeclaration = EvidenceDeclaration [StagedChangesScope, CommitRangeScope] [] [] + +-- | Declared bounds on one review. Exceeding a bound never truncates +-- silently: the uncovered files are reported and the check cannot pass. +data CoverageLimits = CoverageLimits + { maxFileBytes :: !Int, + maxChunkBytes :: !Int, + maxChunks :: !Int, + maxAttempts :: !Int, + timeoutSeconds :: !Int, + maxFindings :: !Int + } + deriving stock (Eq, Show, Generic) + +defaultCoverageLimits :: CoverageLimits +defaultCoverageLimits = + CoverageLimits + { maxFileBytes = 262144, + maxChunkBytes = 49152, + maxChunks = 16, + maxAttempts = 3, + timeoutSeconds = 120, + maxFindings = 20 + } + +-- | The closed, versioned set of deterministic checks. +data DeterministicCheck = SecretScan + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderDeterministicCheck :: DeterministicCheck -> Text +renderDeterministicCheck SecretScan = "secret-scan" + +-- | One author-written yes/no question. +data JudgementCheck = JudgementCheck + { name :: !Text, + question :: !Text, + concernWhen :: !Answer, + yesMeans :: !(Maybe Text), + noMeans :: !(Maybe Text), + categories :: ![FindingCategory], + enforcement :: !Enforcement, + -- | Findings whose category severity is at or above this block. + blockingSeverity :: !Severity, + review :: !Thresholds, + gate :: !Thresholds, + useGate :: !Bool + } + deriving stock (Eq, Show, Generic) + +data JudgementDefinition = JudgementDefinition + { name :: !Text, + version :: !(Maybe Text), + description :: !(Maybe Text), + instructions :: !Text, + evidence :: !EvidenceDeclaration, + limits :: !CoverageLimits, + deterministicChecks :: ![DeterministicCheck], + checks :: !(NonEmpty JudgementCheck) + } + deriving stock (Eq, Show, Generic) + +-- | A module's or recipe's reference to a judgement it activates. The +-- condition is the raw @when@ text, parsed and evaluated by the caller +-- against the referencing module's variables. +data JudgementRef = JudgementRef + { name :: !Text, + source :: !(Maybe Text), + when :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- --------------------------------------------------------------------------- +-- Validation + +-- | A stable machine code and an actionable explanation naming the artifact +-- part as an author writes it. +data JudgementError = JudgementError {code :: !Text, message :: !Text} + deriving stock (Eq, Show, Generic) + +judgementError :: Text -> Text -> JudgementError +judgementError = JudgementError + +validProbability :: Double -> Bool +validProbability p = not (isNaN p || isInfinite p) && p >= 0 && p <= 1 + +validateThresholds :: Text -> Thresholds -> Either JudgementError () +validateThresholds what t = do + forM_ [("blockAt", t ^. #blockAt), ("passAt", t ^. #passAt)] $ \(label, p) -> + unless (validProbability p) $ + Left (judgementError "judgement_threshold_out_of_range" (what <> " " <> label <> " must be between 0 and 1, got " <> T.pack (show p))) + when (t ^. #passAt > t ^. #blockAt) $ + Left + ( judgementError + "judgement_threshold_inverted" + (what <> " passAt (" <> T.pack (show (t ^. #passAt)) <> ") must not exceed blockAt (" <> T.pack (show (t ^. #blockAt)) <> ")") + ) + +-- | Structural validation of a definition. Free of discovery, configuration +-- and prompts, so it can run on a descriptor alone. +validateDefinition :: JudgementDefinition -> Either JudgementError () +validateDefinition def = do + let jname = def ^. #name + validName "judgement" jname + when (T.null (T.strip (def ^. #instructions)) && all (T.null . T.strip . (^. #question)) (def ^. #checks)) $ + Left (judgementError "judgement_empty" ("judgement '" <> jname <> "' has no instructions and no check questions")) + when (null (def ^. #evidence . #scopes)) $ + Left (judgementError "judgement_no_scope" ("judgement '" <> jname <> "' declares no evidence scope")) + forM_ ((def ^. #evidence . #include) <> (def ^. #evidence . #exclude)) $ \pat -> + when (T.null pat || "/" `T.isPrefixOf` pat || ".." `elem` T.splitOn "/" pat) $ + Left (judgementError "judgement_bad_path_pattern" ("judgement '" <> jname <> "' path pattern '" <> pat <> "' must be a non-empty project-relative pattern without '..'")) + validateLimits jname (def ^. #limits) + let names = map (^. #name) (toList (def ^. #checks)) + forM_ (duplicates names) $ \dup -> + Left (judgementError "judgement_duplicate_check" ("judgement '" <> jname <> "' declares check '" <> dup <> "' more than once")) + forM_ (def ^. #checks) $ \check -> do + let cname = check ^. #name + what = "check '" <> cname <> "' of judgement '" <> jname <> "'" + validName "check" cname + when (T.null (T.strip (check ^. #question))) $ + Left (judgementError "judgement_empty_question" (what <> " has an empty question")) + validateThresholds (what <> " review") (check ^. #review) + validateThresholds (what <> " gate") (check ^. #gate) + let cats = map (^. #name) (check ^. #categories) + forM_ cats (validName "finding category") + forM_ (duplicates cats) $ \dup -> + Left (judgementError "judgement_duplicate_category" (what <> " declares finding category '" <> dup <> "' more than once")) + where + validName kind n = + unless (not (T.null n) && T.all (\c -> c `elem` ['a' .. 'z'] || c `elem` ['0' .. '9'] || c == '-') n && T.head n /= '-') $ + Left (judgementError "judgement_bad_name" (kind <> " name '" <> n <> "' must be lowercase letters, digits and hyphens, starting with a letter or digit")) + +validateLimits :: Text -> CoverageLimits -> Either JudgementError () +validateLimits jname l = + forM_ + [ ("maxFileBytes", l ^. #maxFileBytes), + ("maxChunkBytes", l ^. #maxChunkBytes), + ("maxChunks", l ^. #maxChunks), + ("maxAttempts", l ^. #maxAttempts), + ("timeoutSeconds", l ^. #timeoutSeconds), + ("maxFindings", l ^. #maxFindings) + ] + $ \(label, v) -> + when (v <= 0) $ + Left (judgementError "judgement_bad_limit" ("judgement '" <> jname <> "' limit " <> label <> " must be positive, got " <> T.pack (show v))) + +duplicates :: [Text] -> [Text] +duplicates xs = Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(x, 1) | x <- xs])) + +-- --------------------------------------------------------------------------- +-- Policy + +-- | Where review material may be sent. 'LocalOnly' never permits a hosted +-- destination, even through a locally running executable. +data DataPolicy = LocalOnly | ApprovedRemote + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderDataPolicy :: DataPolicy -> Text +renderDataPolicy LocalOnly = "local-only" +renderDataPolicy ApprovedRemote = "approved-remote" + +-- | The effective, project-owned policy for one check. +data CheckPolicy = CheckPolicy + { enforcement :: !Enforcement, + blockingSeverity :: !Severity, + review :: !Thresholds, + gate :: !Thresholds, + useGate :: !Bool + } + deriving stock (Eq, Show, Generic) + +data JudgementPolicy = JudgementPolicy + { dataPolicy :: !DataPolicy, + gatePermitted :: !Bool, + checks :: !(Map Text CheckPolicy) + } + deriving stock (Eq, Show, Generic) + +-- | The policy a definition's authored defaults imply. +defaultPolicy :: DataPolicy -> Bool -> JudgementDefinition -> JudgementPolicy +defaultPolicy dp gatePerm def = + JudgementPolicy + { dataPolicy = dp, + gatePermitted = gatePerm, + checks = Map.fromList [(c ^. #name, fromCheck c) | c <- toList (def ^. #checks)] + } + where + fromCheck c = + CheckPolicy + { enforcement = c ^. #enforcement, + blockingSeverity = c ^. #blockingSeverity, + review = c ^. #review, + gate = c ^. #gate, + useGate = c ^. #useGate + } + +-- | The recorded policy for a check, falling back to its authored defaults. +checkPolicyFor :: JudgementPolicy -> JudgementCheck -> CheckPolicy +checkPolicyFor policy c = + fromMaybe + (CheckPolicy (c ^. #enforcement) (c ^. #blockingSeverity) (c ^. #review) (c ^. #gate) (c ^. #useGate)) + (Map.lookup (c ^. #name) (policy ^. #checks)) + +-- --------------------------------------------------------------------------- +-- Probabilities + +-- | Convert a model's probability of yes into the probability of the +-- concern. This is the only place the concern direction is consulted. +concernProbability :: Answer -> Double -> Double +concernProbability Yes p = p +concernProbability No p = 1 - p + +-- --------------------------------------------------------------------------- +-- Observations + +-- | A validated location inside captured evidence. Lines are 1-based and +-- refer to the post-change content. +data Location = Location + { path :: !FilePath, + line :: !(Maybe Int) + } + deriving stock (Eq, Ord, Show, Generic) + +data Finding = Finding + { category :: !Text, + severity :: !Severity, + location :: !Location, + explanation :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | A finding from a deterministic check. It always blocks. +data DeterministicFinding = DeterministicFinding + { check :: !DeterministicCheck, + rule :: !Text, + location :: !Location + } + deriving stock (Eq, Show, Generic) + +-- | A validated generative review reply for one chunk. +data ReviewObservation = ReviewObservation + { concern :: !Double, + findings :: ![Finding], + requestedHumanReview :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | What the judgment-only gate reported for one chunk. +data GateObservation + = GateAnswered !Double + | GateFailed !Text + deriving stock (Eq, Show, Generic) + +-- | Everything observed for one check over one evidence chunk. +data ChunkObservation = ChunkObservation + { chunk :: !Int, + gate :: !(Maybe GateObservation), + -- | 'Nothing' when no review ran (cleared by the gate, or never sent). + review :: !(Maybe (Either Text ReviewObservation)) + } + deriving stock (Eq, Show, Generic) + +-- | Seihou's own coverage measurement, never the model's. +data Coverage = Coverage + { reviewedFiles :: ![FilePath], + excludedFiles :: ![FilePath], + uncoveredFiles :: ![(FilePath, Text)] + } + deriving stock (Eq, Show, Generic) + +data CheckObservation = CheckObservation + { check :: !Text, + chunks :: ![ChunkObservation], + -- | Errors that prevented review of this check, such as material the + -- transmission safeguard refused to send. + errors :: ![Text] + } + deriving stock (Eq, Show, Generic) + +data JudgementObservation = JudgementObservation + { coverage :: !Coverage, + deterministic :: ![DeterministicFinding], + deterministicErrors :: ![Text], + checks :: ![CheckObservation], + noChanges :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- --------------------------------------------------------------------------- +-- Output validation + +-- | The files a reply may cite, with their post-change line counts. +newtype EvidenceIndex = EvidenceIndex {files :: Map FilePath Int} + deriving stock (Eq, Show, Generic) + +-- | A decoded but not yet validated finding from the runtime adapter. +data RawFinding = RawFinding + { category :: !Text, + path :: !Text, + line :: !(Maybe Int), + explanation :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | A decoded but not yet validated review, with the probability already +-- converted to the probability of the concern. +data RawReview = RawReview + { concern :: !Double, + findings :: ![RawFinding], + requestedHumanReview :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | Enforce the domain after decoding: declared categories, locations inside +-- the captured evidence, bounded output and a probability in range. The +-- model reports evidence; it never chooses a category's severity. +validateReview :: CoverageLimits -> JudgementCheck -> EvidenceIndex -> RawReview -> Either Text ReviewObservation +validateReview limits check index raw = do + unless (validProbability (raw ^. #concern)) $ + Left ("the reply's probability " <> renderProbability (raw ^. #concern) <> " is outside 0 to 1") + when (length (raw ^. #findings) > limits ^. #maxFindings) $ + Left ("the reply has " <> T.pack (show (length (raw ^. #findings))) <> " findings, more than the limit of " <> T.pack (show (limits ^. #maxFindings))) + let declared = Map.fromList [(c ^. #name, c ^. #severity) | c <- check ^. #categories] + found <- traverse (validateFinding declared) (raw ^. #findings) + pure (ReviewObservation (raw ^. #concern) found (raw ^. #requestedHumanReview)) + where + validateFinding declared f = do + sev <- case Map.lookup (f ^. #category) declared of + Just s -> Right s + Nothing -> Left ("the reply uses finding category '" <> bounded 64 (f ^. #category) <> "', which check '" <> check ^. #name <> "' does not declare") + let p = T.unpack (f ^. #path) + lineCount <- case Map.lookup p (index ^. #files) of + Just n -> Right n + Nothing -> Left ("the reply cites '" <> bounded 200 (f ^. #path) <> "', which is not in the reviewed evidence") + forM_ (f ^. #line) $ \l -> + when (l < 1 || l > max 1 lineCount) $ + Left ("the reply cites line " <> T.pack (show l) <> " of '" <> T.pack p <> "', which has " <> T.pack (show lineCount) <> " lines") + pure (Finding (f ^. #category) sev (Location p (f ^. #line)) (bounded 500 (f ^. #explanation))) + +bounded :: Int -> Text -> Text +bounded n t + | T.length t <= n = t + | otherwise = T.take n t <> "…" + +findingBlocks :: CheckPolicy -> Finding -> Bool +findingBlocks policy f = f ^. #severity >= policy ^. #blockingSeverity + +-- --------------------------------------------------------------------------- +-- Decisions + +data CheckStatus = CheckPassed | CheckBlocked | CheckNeedsReview | CheckFailed | CheckNoChanges + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderCheckStatus :: CheckStatus -> Text +renderCheckStatus = \case + CheckPassed -> "passed" + CheckBlocked -> "blocked" + CheckNeedsReview -> "needs review" + CheckFailed -> "error" + CheckNoChanges -> "no changes" + +-- | Ranking used to combine outcomes: block above needs-review above error +-- above pass above no-changes. +statusSeverity :: CheckStatus -> Int +statusSeverity = \case + CheckBlocked -> 4 + CheckNeedsReview -> 3 + CheckFailed -> 2 + CheckPassed -> 1 + CheckNoChanges -> 0 + +-- | Which route decided a chunk. +data DecidedBy = DecidedByGate | DecidedByReview | DecidedByNone + deriving stock (Eq, Ord, Show, Generic) + +-- | Why a check reached its status. Rendered for humans; the constructors +-- are stable for JSON reports. +data DecisionReason + = BlockingFinding !Finding + | ConcernAtOrAboveBlock !Double !Double + | ConcernInBand !Double !Thresholds + | ConcernAtOrBelowPass !Double !Double + | ModelRequestedReview + | GateCleared !Double !Double + | GateEscalated !Double !Double + | GateDisagreed !Double !Double + | GateUnavailable !Text + | ReviewMissing + | ReviewError !Text + | CheckError !Text + deriving stock (Eq, Show, Generic) + +renderDecisionReason :: DecisionReason -> Text +renderDecisionReason = \case + BlockingFinding f -> "blocking " <> renderSeverity (f ^. #severity) <> " finding '" <> f ^. #category <> "' at " <> renderLoc (f ^. #location) + ConcernAtOrAboveBlock p t -> "model-reported probability " <> fmt p <> " is at or above block threshold " <> fmt t <> "; the review located no blocking finding" + ConcernInBand p t -> "model-reported probability " <> fmt p <> " is between pass at " <> fmt (t ^. #passAt) <> " and block at " <> fmt (t ^. #blockAt) + ConcernAtOrBelowPass p t -> "model-reported probability " <> fmt p <> " is at or below pass threshold " <> fmt t + ModelRequestedReview -> "the model requested human review" + GateCleared p t -> "cleared by gate, probability " <> fmt p <> " at or below " <> fmt t + GateEscalated p t -> "gate probability " <> fmt p <> " above gate pass threshold " <> fmt t <> "; escalated to review" + GateDisagreed p t -> "gate probability " <> fmt p <> " reached gate block threshold " <> fmt t <> "; the review cannot pass this check" + GateUnavailable why -> "gate unavailable (" <> why <> "); escalated to review" + ReviewMissing -> "escalated, but no review result was produced" + ReviewError why -> "review failed: " <> why + CheckError why -> why + where + renderLoc l = T.pack (l ^. #path) <> maybe "" (\n -> ":" <> T.pack (show n)) (l ^. #line) + +fmt :: Double -> Text +fmt = renderProbability + +-- | A probability as a reader expects it, with two decimals: @0.02@, not +-- @2.0e-2@. Values outside 0 to 1 are rendered the same way so a diagnostic +-- can name them. +renderProbability :: Double -> Text +renderProbability p + | isNaN p || isInfinite p = T.pack (show p) + | otherwise = + let hundredths = round (abs p * 100) :: Integer + (whole, frac) = hundredths `divMod` 100 + in (if p < 0 && hundredths /= 0 then "-" else "") <> T.pack (show whole) <> "." <> (if frac < 10 then "0" else "") <> T.pack (show frac) + +data ChunkDecision = ChunkDecision + { chunk :: !Int, + status :: !CheckStatus, + decidedBy :: !DecidedBy, + gateConcern :: !(Maybe Double), + reviewConcern :: !(Maybe Double), + findings :: ![Finding], + reasons :: ![DecisionReason] + } + deriving stock (Eq, Show, Generic) + +data CheckDecision = CheckDecision + { check :: !Text, + status :: !CheckStatus, + enforcement :: !Enforcement, + policy :: !CheckPolicy, + chunks :: ![ChunkDecision], + -- | The governing (highest) concern probabilities over all chunks. + gateConcern :: !(Maybe Double), + reviewConcern :: !(Maybe Double), + findings :: ![Finding], + reasons :: ![DecisionReason] + } + deriving stock (Eq, Show, Generic) + +-- | Apply one check's policy to one chunk's observation. +-- +-- * The gate clears a chunk at or below its pass threshold; no review is +-- needed. A higher gate probability escalates, and a gate probability at or +-- above its block threshold forbids the review from passing the chunk. +-- * A gate failure escalates visibly; it is neither an error nor a clearance. +-- * In the review, a blocking finding blocks; a probability at or above the +-- block threshold blocks even without a location; a probability above the +-- pass threshold, or a request for human review, needs review; only a +-- probability at or below the pass threshold passes. +decideChunk :: Bool -> CheckPolicy -> ChunkObservation -> ChunkDecision +decideChunk gateActive policy obs = + case (if gateActive && policy ^. #useGate then obs ^. #gate else Nothing) of + Just (GateAnswered g) + | g <= gatePass && validProbability g -> + ChunkDecision (obs ^. #chunk) CheckPassed DecidedByGate (Just g) Nothing [] [GateCleared g gatePass] + | validProbability g -> + let escalation = GateEscalated g gatePass + disagree = g >= gateBlock + d = fromReview (Just g) [escalation] + in if disagree && d ^. #status == CheckPassed + then d & #status .~ CheckNeedsReview & #reasons %~ (<> [GateDisagreed g gateBlock]) + else d + | otherwise -> + fromReview Nothing [GateUnavailable ("probability " <> renderProbability g <> " is outside 0 to 1")] + Just (GateFailed why) -> fromReview Nothing [GateUnavailable why] + Nothing -> fromReview Nothing [] + where + gatePass = policy ^. #gate . #passAt + gateBlock = policy ^. #gate . #blockAt + reviewT = policy ^. #review + fromReview gateP prior = case obs ^. #review of + Nothing -> ChunkDecision (obs ^. #chunk) CheckFailed DecidedByNone gateP Nothing [] (prior <> [ReviewMissing]) + Just (Left why) -> ChunkDecision (obs ^. #chunk) CheckFailed DecidedByReview gateP Nothing [] (prior <> [ReviewError why]) + Just (Right r) -> + let p = r ^. #concern + blocking = filter (findingBlocks policy) (r ^. #findings) + (status, reasons) + | not (validProbability p) = (CheckFailed, [ReviewError ("probability " <> renderProbability p <> " is outside 0 to 1")]) + | not (null blocking) = (CheckBlocked, map BlockingFinding blocking) + | p >= reviewT ^. #blockAt = (CheckBlocked, [ConcernAtOrAboveBlock p (reviewT ^. #blockAt)]) + | p > reviewT ^. #passAt = (CheckNeedsReview, [ConcernInBand p reviewT] <> [ModelRequestedReview | r ^. #requestedHumanReview]) + | r ^. #requestedHumanReview = (CheckNeedsReview, [ModelRequestedReview]) + | otherwise = (CheckPassed, [ConcernAtOrBelowPass p (reviewT ^. #passAt)]) + in ChunkDecision (obs ^. #chunk) status DecidedByReview gateP (Just p) (r ^. #findings) (prior <> reasons) + +-- | Combine a check's chunks. The most severe chunk governs, and the highest +-- probability over all chunks is reported. A check with no chunks and no +-- errors had nothing in scope. +decideCheck :: Bool -> Coverage -> CheckPolicy -> CheckObservation -> CheckDecision +decideCheck gateActive coverage policy obs = + CheckDecision + { check = obs ^. #check, + status = finalStatus, + enforcement = policy ^. #enforcement, + policy = policy, + chunks = decided, + gateConcern = maximumMaybe (mapMaybe (^. #gateConcern) decided), + reviewConcern = maximumMaybe (mapMaybe (^. #reviewConcern) decided), + findings = concatMap (^. #findings) decided, + reasons = map CheckError (obs ^. #errors) <> uncoveredReasons <> concatMap (^. #reasons) decided + } + where + decided = map (decideChunk gateActive policy) (obs ^. #chunks) + uncovered = coverage ^. #uncoveredFiles + uncoveredReasons = [CheckError ("'" <> T.pack p <> "' was not reviewed: " <> why) | (p, why) <- uncovered] + chunkStatus = case sortOn (Down . statusSeverity) (map (^. #status) decided) of + (s : _) -> s + [] -> CheckNoChanges + finalStatus + | not (null (obs ^. #errors)) = worst [chunkStatus, CheckFailed] + | not (null uncovered) = worst [chunkStatus, CheckFailed] + | otherwise = chunkStatus + worst = NE.head . NE.sortWith (Down . statusSeverity) . NE.fromList + +maximumMaybe :: [Double] -> Maybe Double +maximumMaybe [] = Nothing +maximumMaybe xs = Just (maximum xs) + +data JudgementStatus = Passed | Blocked | NeedsReview | Failed | NoChanges + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderJudgementStatus :: JudgementStatus -> Text +renderJudgementStatus = \case + Passed -> "PASSED" + Blocked -> "BLOCKED" + NeedsReview -> "NEEDS REVIEW" + Failed -> "ERROR" + NoChanges -> "NO CHANGES" + +data JudgementDecision = JudgementDecision + { judgement :: !Text, + status :: !JudgementStatus, + deterministic :: ![DeterministicFinding], + deterministicErrors :: ![Text], + checks :: ![CheckDecision], + coverage :: !Coverage + } + deriving stock (Eq, Show, Generic) + +-- | Combine a judgement's checks under its policy. A deterministic finding +-- blocks regardless of any probability. Among enforced checks the most +-- severe outcome governs: block, then needs-review, then error. Advisory +-- checks are reported with their real status and never affect the result. +-- Empty evidence is 'NoChanges', an explicit no-op rather than a review. +decideJudgement :: JudgementDefinition -> JudgementPolicy -> JudgementObservation -> JudgementDecision +decideJudgement def policy obs = + JudgementDecision + { judgement = def ^. #name, + status = overall, + deterministic = obs ^. #deterministic, + deterministicErrors = obs ^. #deterministicErrors, + checks = decisions, + coverage = obs ^. #coverage + } + where + gateActive = policy ^. #gatePermitted + observed = Map.fromList [(o ^. #check, o) | o <- obs ^. #checks] + decisions = + [ decideCheck gateActive (obs ^. #coverage) (checkPolicyFor policy c) (Map.findWithDefault (missing c) (c ^. #name) observed) + | c <- toList (def ^. #checks) + ] + missing c + | obs ^. #noChanges = CheckObservation (c ^. #name) [] [] + | otherwise = CheckObservation (c ^. #name) [] ["check '" <> c ^. #name <> "' produced no observation"] + enforced = [d ^. #status | d <- decisions, d ^. #enforcement == Enforced] + overall + | not (null (obs ^. #deterministic)) = Blocked + | CheckBlocked `elem` enforced = Blocked + | CheckNeedsReview `elem` enforced = NeedsReview + | CheckFailed `elem` enforced || not (null (obs ^. #deterministicErrors)) = Failed + | obs ^. #noChanges = NoChanges + | all (== CheckNoChanges) enforced && not (null enforced) = NoChanges + | otherwise = Passed diff --git a/src/Seihou/Core/JudgementExamples.hs b/src/Seihou/Core/JudgementExamples.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/JudgementExamples.hs @@ -0,0 +1,141 @@ +-- | Labelled examples for a judgement: synthetic changes and the outcome +-- each check should reach on them. +-- +-- An @examples.json@ file sits beside @judgement.dhall@. Its cases are +-- synthetic by contract: evaluation submits them to a model, and a scanner +-- pass over them runs first. Validation here is structural and needs only +-- the definition, so @validate-judgement@ can name every problem before any +-- provider call. +-- +-- Format, version 1: +-- +-- > { "version": 1, +-- > "examples": [ +-- > { "id": "benign-readme", +-- > "description": "A documentation-only change", +-- > "files": [ { "path": "README.md", "content": "..." } ], +-- > "expect": { "stale-docs": "passed", "has-example": "blocked" }, +-- > "findings": [ { "check": "has-example", "category": "missing-example", "path": "README.md", "line": 3 } ] } ] } +-- +-- @expect@ maps check names to @passed@, @blocked@ or @needs-review@; a +-- check left out is not scored on that case. @findings@ is optional. +module Seihou.Core.JudgementExamples + ( ExampleFile (..), + ExpectedFinding (..), + JudgementExample (..), + JudgementExamples (..), + ExpectedStatus (..), + renderExpectedStatus, + parseExamples, + validateExamples, + ) +where + +import Control.Monad (forM_, when) +import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Seihou.Core.Judgement +import Seihou.Prelude hiding ((.=)) + +data ExpectedStatus = ExpectPassed | ExpectBlocked | ExpectNeedsReview + deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) + +renderExpectedStatus :: ExpectedStatus -> Text +renderExpectedStatus = \case + ExpectPassed -> "passed" + ExpectBlocked -> "blocked" + ExpectNeedsReview -> "needs-review" + +data ExampleFile = ExampleFile {path :: !FilePath, content :: !Text} + deriving stock (Eq, Show, Generic) + +data ExpectedFinding = ExpectedFinding + { check :: !Text, + category :: !Text, + path :: !FilePath, + line :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +data JudgementExample = JudgementExample + { id :: !Text, + description :: !(Maybe Text), + files :: ![ExampleFile], + expect :: !(Map Text ExpectedStatus), + findings :: ![ExpectedFinding] + } + deriving stock (Eq, Show, Generic) + +data JudgementExamples = JudgementExamples + { version :: !Int, + examples :: ![JudgementExample] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ExpectedStatus where + parseJSON = Aeson.withText "ExpectedStatus" $ \t -> case [s | s <- [minBound .. maxBound], renderExpectedStatus s == t] of + [s] -> pure s + _ -> fail ("unknown expected status '" <> T.unpack t <> "'; expected passed, blocked or needs-review") + +instance FromJSON ExampleFile where + parseJSON = withObject "ExampleFile" $ \o -> ExampleFile <$> o .: "path" <*> o .: "content" + +instance FromJSON ExpectedFinding where + parseJSON = withObject "ExpectedFinding" $ \o -> ExpectedFinding <$> o .: "check" <*> o .: "category" <*> o .: "path" <*> o .:? "line" + +instance FromJSON JudgementExample where + parseJSON = withObject "JudgementExample" $ \o -> + JudgementExample + <$> o .: "id" + <*> o .:? "description" + <*> o .: "files" + <*> o .: "expect" + <*> (fromMaybe [] <$> o .:? "findings") + +instance FromJSON JudgementExamples where + parseJSON = withObject "JudgementExamples" $ \o -> JudgementExamples <$> o .: "version" <*> o .: "examples" + +-- | Decode @examples.json@ bytes, naming the file in the error. +parseExamples :: FilePath -> LBS.ByteString -> Either JudgementError JudgementExamples +parseExamples file bytes = case Aeson.eitherDecode bytes of + Left err -> Left (judgementError "judgement_examples_malformed" (T.pack file <> " is not a valid examples file: " <> T.pack err)) + Right ex + | ex ^. #version /= 1 -> Left (judgementError "judgement_examples_version" (T.pack file <> " has version " <> T.pack (show (ex ^. #version)) <> "; this seihou reads version 1")) + | otherwise -> Right ex + +-- | Every structural problem, in file order, as named diagnostics. +validateExamples :: JudgementDefinition -> JudgementExamples -> [JudgementError] +validateExamples def ex = either pure (const []) checkIds <> concatMap one (ex ^. #examples) + where + checks = Map.fromList [(c ^. #name, c) | c <- toList (def ^. #checks)] + checkIds = do + let ids = map (^. #id) (ex ^. #examples) + when (null ids) $ Left (judgementError "judgement_examples_empty" "the examples file has no examples") + forM_ (Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(i, 1) | i <- ids]))) $ \dup -> + Left (judgementError "judgement_example_duplicate_id" ("example id '" <> dup <> "' is used more than once")) + one e = + let eid = "example '" <> e ^. #id <> "'" + paths = map (^. #path) (e ^. #files) + in [judgementError "judgement_example_bad_id" (eid <> ": ids must be non-empty") | T.null (T.strip (e ^. #id))] + <> [judgementError "judgement_example_no_files" (eid <> " has no files") | null (e ^. #files)] + <> [ judgementError "judgement_example_bad_path" (eid <> " file path '" <> T.pack p <> "' must be project-relative without '..'") + | p <- paths, + null p || "/" `T.isPrefixOf` T.pack p || ".." `elem` T.splitOn "/" (T.pack p) + ] + <> [judgementError "judgement_example_unknown_check" (eid <> " expects an outcome for check '" <> c <> "', which the judgement does not declare") | c <- Map.keys (e ^. #expect), not (Map.member c checks)] + <> [judgementError "judgement_example_no_expectation" (eid <> " expects no outcome for any check") | Map.null (e ^. #expect)] + <> concatMap (finding eid paths) (e ^. #findings) + finding eid paths f = case Map.lookup (f ^. #check) checks of + Nothing -> [judgementError "judgement_example_unknown_check" (eid <> " lists a finding for check '" <> f ^. #check <> "', which the judgement does not declare")] + Just c -> + [ judgementError "judgement_example_unknown_category" (eid <> " lists finding category '" <> f ^. #category <> "', which check '" <> c ^. #name <> "' does not declare") + | f ^. #category `notElem` map (^. #name) (c ^. #categories) + ] + <> [judgementError "judgement_example_unknown_file" (eid <> " lists a finding in '" <> T.pack (f ^. #path) <> "', which is not one of its files") | f ^. #path `notElem` paths] + <> [judgementError "judgement_example_bad_line" (eid <> " lists a finding at line " <> T.pack (show l) <> "; lines start at 1") | Just l <- [f ^. #line], l < 1] diff --git a/src/Seihou/Core/JudgementState.hs b/src/Seihou/Core/JudgementState.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/JudgementState.hs @@ -0,0 +1,104 @@ +-- | Pure rules for the manifest's active judgements: adopting with an owner, +-- and retiring owners. +-- +-- Agreeing owners share one record. Re-adopting an unchanged definition keeps +-- the project's recorded policy, so a policy changed with +-- @seihou judgement configure@ survives re-application. A changed definition +-- replaces the record only when no other owner holds the old one; otherwise +-- adoption is refused before anything is published. +module Seihou.Core.JudgementState + ( AdoptionChange (..), + adoptWithOwner, + pruneJudgementOwners, + retireOwner, + policyWeakenings, + ) +where + +import Data.Generics.Labels () +import Data.List (nub) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Core.Judgement (Enforcement (..), renderProbability) +import Seihou.Core.Types +import Seihou.Prelude + +data AdoptionChange + = AdoptedNew + | -- | Same definition: only the owner set may have grown. + AdoptedUnchanged + | -- | The definition changed and replaced the recorded one. + AdoptedReplacing !ActiveJudgement + deriving stock (Eq, Show, Generic) + +-- | Add @candidate@ for @owner@ to the active list. +adoptWithOwner :: JudgementOwner -> ActiveJudgement -> [ActiveJudgement] -> Either Text ([ActiveJudgement], AdoptionChange) +adoptWithOwner owner candidate active = case break sameName active of + (_, []) -> Right (active <> [candidate & #owners .~ [owner]], AdoptedNew) + (before, prior : after) + | prior ^. #digest == candidate ^. #digest -> + Right (before <> [prior & #owners %~ (nub . (<> [owner]))] <> after, AdoptedUnchanged) + | any (/= owner) (prior ^. #owners) -> + Left + ( "Judgement '" + <> name + <> "' is already active with a different definition for " + <> T.intercalate ", " (map renderOwner (filter (/= owner) (prior ^. #owners))) + <> ". Update that owner, or remove it, before adopting this definition." + ) + | otherwise -> Right (before <> [candidate & #owners .~ [owner]] <> after, AdoptedReplacing prior) + where + name = candidate ^. #definition . #name + sameName j = j ^. #definition . #name == name + +renderOwner :: JudgementOwner -> Text +renderOwner = \case + DirectAdoption -> "a direct seihou run" + ApplicationOwner (ApplicationId i) -> "application " <> T.take 12 i + +-- | Remove one owner everywhere; returns the remaining records and the names +-- of judgements that lost their last owner. +retireOwner :: JudgementOwner -> [ActiveJudgement] -> ([ActiveJudgement], [Text]) +retireOwner owner = settle . map (#owners %~ filter (/= owner)) + +-- | Drop application owners whose application is no longer recorded. +pruneJudgementOwners :: Manifest -> (Manifest, [Text]) +pruneJudgementOwners m = + let live = Set.fromList (map (^. #applicationId) (m ^. #applications)) + keep = \case + ApplicationOwner a -> Set.member a live + DirectAdoption -> True + (remaining, retired) = settle (map (#owners %~ filter keep) (m ^. #judgements)) + in (m & #judgements .~ remaining, retired) + +settle :: [ActiveJudgement] -> ([ActiveJudgement], [Text]) +settle js = ([j | j <- js, not (null (j ^. #owners))], [j ^. #definition . #name | j <- js, null (j ^. #owners)]) + +-- | How a proposed set of active judgements is weaker than a trusted one: +-- a judgement removed, a check made advisory, or a review threshold raised. +-- Used to report a staged policy change instead of letting it pass as an +-- ordinary clean result. +policyWeakenings :: [ActiveJudgement] -> [ActiveJudgement] -> [Text] +policyWeakenings trusted proposed = concatMap one trusted + where + one t = case [p | p <- proposed, p ^. #definition . #name == name] of + [] -> ["judgement '" <> name <> "' is no longer active"] + (p : _) -> + concat + [ [ "check '" <> c <> "' of '" <> name <> "' is now advisory" + | tc ^. #enforcement == Enforced, + pc ^. #enforcement == Advisory + ] + <> [ "check '" <> c <> "' of '" <> name <> "' blocks at " <> renderProbability (pc ^. #review . #blockAt) <> " instead of " <> renderProbability (tc ^. #review . #blockAt) + | pc ^. #review . #blockAt > tc ^. #review . #blockAt + ] + <> [ "check '" <> c <> "' of '" <> name <> "' passes at " <> renderProbability (pc ^. #review . #passAt) <> " instead of " <> renderProbability (tc ^. #review . #passAt) + | pc ^. #review . #passAt > tc ^. #review . #passAt + ] + | (c, tc) <- Map.toList (t ^. #policy . #checks), + Just pc <- [Map.lookup c (p ^. #policy . #checks)] + ] + <> ["check '" <> c <> "' of '" <> name <> "' was removed" | c <- Map.keys (t ^. #policy . #checks), not (Map.member c (p ^. #policy . #checks))] + where + name = t ^. #definition . #name diff --git a/src/Seihou/Core/Migration.hs b/src/Seihou/Core/Migration.hs --- a/src/Seihou/Core/Migration.hs +++ b/src/Seihou/Core/Migration.hs @@ -39,6 +39,8 @@ -- manifest. -- * 'DeleteDir' — remove a directory recursively and drop every manifest -- entry under that prefix. +-- * 'RemoveLine' — remove every exact logical line, preserving unrelated +-- bytes and terminators. Missing targets or matches are no-ops. -- * 'RunCommand' — execute a shell command. The manifest is not rewritten -- by this op; if the command moves files, the migration author is -- responsible for following it with explicit move/delete ops. @@ -47,6 +49,7 @@ | MoveDir {src :: !FilePath, dest :: !FilePath} | DeleteFile {path :: !FilePath} | DeleteDir {path :: !FilePath} + | RemoveLine {path :: !FilePath, line :: !Text} | RunCommand {run :: !Text, workDir :: !(Maybe FilePath)} deriving stock (Eq, Show, Generic) diff --git a/src/Seihou/Core/Module.hs b/src/Seihou/Core/Module.hs --- a/src/Seihou/Core/Module.hs +++ b/src/Seihou/Core/Module.hs @@ -23,6 +23,7 @@ checkDependencyNames, checkDependencyVarBindings, checkSafeDestinations, + checkModuleStateDestinations, checkDestVarRefs, checkCommandSafety, checkSeedSteps, @@ -38,10 +39,11 @@ import Data.Maybe (isJust, maybeToList) import Data.Set qualified as Set import Data.Text qualified as T +import Seihou.Core.ArtifactFiles (judgementAmbiguity) import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths) -import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), controlPathReason, ownStateDirectoryViolation, validateProjectRelativePath) import Seihou.Core.Types -import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRecipeFromFile) +import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalJudgementFromFile, evalModuleFromFile, evalRecipeFromFile) import Seihou.Prelude import System.Directory (XdgDirectory (..), doesDirectoryExist, doesFileExist, getCurrentDirectory, getXdgDirectory, listDirectory) @@ -69,7 +71,9 @@ -- (returning 'RunnableAgentPrompt'). Within a single candidate directory -- the priority is module > recipe > blueprint > prompt, so a stray -- @module.dhall@ next to a @blueprint.dhall@ silently surfaces the --- module — the more specific, deterministic artifact. Returns +-- module — the more specific, deterministic artifact. A @judgement.dhall@ +-- (returning 'RunnableJudgement') does not join that precedence: next to any +-- other definition file it is 'AmbiguousArtifact'. Returns -- 'ModuleNotFound' if none is found in any search path. discoverRunnable :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError Runnable) discoverRunnable searchPaths name = go searchPaths @@ -78,7 +82,12 @@ go [] = pure $ Left (ModuleNotFound name searchPaths) go (dir : rest) = do let candidate = dir nameStr - moduleDhall = candidate "module.dhall" + ambiguity <- judgementAmbiguity candidate + case ambiguity of + Just files -> pure (Left (AmbiguousArtifact name candidate files)) + Nothing -> probe candidate rest + probe candidate rest = do + let moduleDhall = candidate "module.dhall" recipeDhall = candidate "recipe.dhall" blueprintDhall = candidate "blueprint.dhall" promptDhall = candidate "prompt.dhall" @@ -113,7 +122,14 @@ case result of Left err -> pure (Left err) Right p -> pure (Right (RunnableAgentPrompt p candidate)) - else go rest + else do + let judgementDhall = candidate "judgement.dhall" + isJudgement <- doesFileExist judgementDhall + if isJudgement + then do + result <- evalJudgementFromFile judgementDhall + pure (fmap (`RunnableJudgement` candidate) result) + else go rest -- | Search for a blueprint by name in the given directories. Returns -- the path to the directory containing @blueprint.dhall@, or @@ -293,15 +309,45 @@ ) (m ^. #dependencies) --- Rule 7: Every step destination must be a safe relative path +-- Rule 7: Every step destination must be a safe relative path and must not +-- target Seihou's or Git's control data. Only the control rule applies when a +-- module loads; the rule that a module writes under @.seihou/@ only inside its +-- own directory is 'checkModuleStateDestinations', enforced when output is +-- generated, so that existing applications of an older module still load for +-- @seihou remove@ and @seihou status@. checkSafeDestinations :: Module -> [Text] checkSafeDestinations m = concatMap checkDest (m ^. #steps) where checkDest s = case validateProjectRelativePath (s ^. #dest) of Left err -> ["step destination " <> err] - Right _ -> [] + Right safePath + | literalControlPrefix (s ^. #dest), + Just reason <- controlPathReason FileTarget safePath -> + ["step destination " <> reason] + | otherwise -> [] +-- | A module may write under @.seihou/@ only inside @.seihou//@. +-- Checks each literal step destination; one whose first two segments contain a +-- placeholder is left to plan time. Control paths are reported by +-- 'checkSafeDestinations' and are not repeated here. +checkModuleStateDestinations :: Module -> [Text] +checkModuleStateDestinations m = concatMap checkDest (m ^. #steps) + where + checkDest s = case validateProjectRelativePath (s ^. #dest) of + Right safePath + | literalControlPrefix (s ^. #dest), + Nothing <- controlPathReason FileTarget safePath, + Just violation <- ownStateDirectoryViolation (m ^. #name . #unModuleName) FileTarget safePath -> + ["step destination " <> violation] + _ -> [] + +-- | Whether the segments that decide a path's control class (the first two) +-- are free of placeholders, so the literal destination can be judged now. +literalControlPrefix :: Text -> Bool +literalControlPrefix dest = + not (any ("{{" `T.isInfixOf`) (take 2 (filter (not . T.null) (T.split (\c -> c == '/' || c == '\\') dest)))) + -- Rule 8: Variables referenced in step dest placeholders must be declared checkDestVarRefs :: Module -> [Text] checkDestVarRefs m = @@ -411,7 +457,7 @@ pure DiscoveredModule {result = result, source = src, dir = moduleDir} -- | Whether a discovered item is a module, recipe, blueprint, or prompt. -data RunnableKind = KindModule | KindRecipe | KindBlueprint | KindPrompt +data RunnableKind = KindModule | KindRecipe | KindBlueprint | KindPrompt | KindJudgement deriving stock (Eq, Show, Generic) -- | A runnable discovered during enumeration, with its load result, kind, and source. @@ -426,8 +472,10 @@ } deriving stock (Generic, Show) --- | Enumerate all modules, recipes, blueprints, and prompts across the given search paths. --- Returns a unified list of discovered items, each tagged with its kind. +-- | Enumerate all modules, recipes, blueprints, prompts, and judgements across +-- the given search paths. Returns a unified list of discovered items, each +-- tagged with its kind. A directory whose @judgement.dhall@ shares it with +-- another definition file is listed once, as an erroring judgement. discoverAllRunnables :: [FilePath] -> IO [DiscoveredRunnable] discoverAllRunnables searchPaths = do let tagged = zip searchPaths (sources ++ repeat SourceInstalled) @@ -446,6 +494,24 @@ loadRunnable :: FilePath -> ModuleSource -> FilePath -> IO [DiscoveredRunnable] loadRunnable dir src entry = do + ambiguity <- judgementAmbiguity (dir entry) + case ambiguity of + Just files -> + pure + [ DiscoveredRunnable + { name = T.pack entry, + description = Nothing, + kind = KindJudgement, + source = src, + dir = dir entry, + isError = True, + error = Just ("ambiguous: " <> T.intercalate ", " (map T.pack files)) + } + ] + Nothing -> loadUnambiguous dir src entry + + loadUnambiguous :: FilePath -> ModuleSource -> FilePath -> IO [DiscoveredRunnable] + loadUnambiguous dir src entry = do let entryDir = dir entry moduleDhall = entryDir "module.dhall" recipeDhall = entryDir "recipe.dhall" @@ -562,8 +628,40 @@ error = Nothing } ] - else pure [] + else loadJudgement src entry entryDir + loadJudgement :: ModuleSource -> FilePath -> FilePath -> IO [DiscoveredRunnable] + loadJudgement src entry entryDir = do + let judgementDhall = entryDir "judgement.dhall" + isJudgement <- doesFileExist judgementDhall + if not isJudgement + then pure [] + else do + decoded <- evalJudgementFromFile judgementDhall + pure + [ case decoded of + Left err -> + DiscoveredRunnable + { name = T.pack entry, + description = Nothing, + kind = KindJudgement, + source = src, + dir = entryDir, + isError = True, + error = Just (briefLoadError err) + } + Right j -> + DiscoveredRunnable + { name = j ^. #name, + description = j ^. #description, + kind = KindJudgement, + source = src, + dir = entryDir, + isError = False, + error = Nothing + } + ] + briefLoadError :: ModuleLoadError -> Text briefLoadError (DhallEvalError _ _) = "Dhall evaluation failed" briefLoadError (DhallDecodeError _ _) = "Dhall decode failed" @@ -572,6 +670,7 @@ briefLoadError (MissingSourceFile _ _) = "missing source file" briefLoadError (CircularDependency _) = "circular dependency" briefLoadError (RegistryEvalError _ _) = "registry eval failed" + briefLoadError (AmbiguousArtifact _ _ _) = "ambiguous artifact" -- | A seed creates an entire file and must never be subject to automatic removal. checkSeedSteps :: Module -> [Text] diff --git a/src/Seihou/Core/Path.hs b/src/Seihou/Core/Path.hs --- a/src/Seihou/Core/Path.hs +++ b/src/Seihou/Core/Path.hs @@ -2,9 +2,20 @@ ( validateProjectRelativePath, validateCanonicalProjectPath, pathsHaveConflictingSpelling, + + -- * Seihou and Git control paths + ProjectPathClass (..), + PathOperand (..), + classifyProjectPath, + reservedSeihouEntries, + isControlFileTarget, + isControlDirectory, + controlPathReason, + ownStateDirectoryViolation, ) where +import Data.Maybe (isJust) import Data.Text qualified as T import Seihou.Prelude import System.FilePath qualified as FilePath @@ -29,6 +40,113 @@ pathSegments = filter (not . T.null) . T.split (\c -> c == '/' || c == '\\') + +-- | What a validated project-relative path names, for the rules that keep +-- module output away from Seihou's and Git's own data. +-- +-- A module owns exactly one directory under @.seihou/@, named after itself; +-- everything on 'reservedSeihouEntries' belongs to Seihou. See +-- docs/adr/0025-a-module-owns-only-its-own-directory-under-seihou.md. +data ProjectPathClass + = -- | An ordinary project path, outside @.seihou@ and @.git@. + OrdinaryProjectPath + | -- | The @.seihou@ directory itself: creatable as a directory, never a file. + SeihouRootDirectory + | -- | Under @.seihou/@, where @@ (as written) is not Seihou's own. + -- The 'Bool' says whether the path continues below the area directory. + ModuleStatePath !Text !Bool + | -- | Seihou's own state or Git's; the 'Text' is the user-facing reason. + ControlPath !Text + deriving stock (Eq, Show, Generic) + +-- | Whether a path names a file to write or a directory to create. +data PathOperand = FileTarget | DirectoryOperand + deriving stock (Eq, Show, Generic) + +-- | The entries directly under @.seihou/@ that Seihou itself owns, case-folded. +-- Every name beginning with @.@ is reserved as well. New Seihou state under +-- @.seihou/@ must be added here and must use a name that is not a valid module +-- name (one not matching @[a-z][a-z0-9-]*@), so it never collides with a +-- module's state directory. +reservedSeihouEntries :: [Text] +reservedSeihouEntries = + [ "manifest.json", + "manifest.json.tmp", + "baselines", + "transactions", + "transactions-quarantine", + "modules", + "context", + "config.dhall", + "trace.jsonl" + ] + +-- | Classify a path that has already passed 'validateProjectRelativePath'. +-- Segments split on either separator; empty and @.@ segments are ignored, and +-- the @.seihou@, @.git@ and reserved names compare case-insensitively because +-- the default macOS volume does. +classifyProjectPath :: FilePath -> ProjectPathClass +classifyProjectPath path = case controlSegments path of + first' : rest + | T.toCaseFold first' == ".git" -> ControlPath "path targets Git control data" + | T.toCaseFold first' == ".seihou" -> case rest of + [] -> SeihouRootDirectory + entry : below + | isReservedSeihouEntry entry -> + ControlPath ("path targets Seihou's own state at " <> first' <> "/" <> entry) + | otherwise -> ModuleStatePath entry (not (null below)) + _ -> OrdinaryProjectPath + +controlSegments :: FilePath -> [Text] +controlSegments = filter (/= ".") . pathSegments . T.pack + +isReservedSeihouEntry :: Text -> Bool +isReservedSeihouEntry entry = + "." `T.isPrefixOf` entry || T.toCaseFold entry `elem` reservedSeihouEntries + +-- | A path no module output may write as a file: Seihou's or Git's control +-- data, or the @.seihou@ directory itself. +isControlFileTarget :: FilePath -> Bool +isControlFileTarget = isJust . controlPathReason FileTarget + +-- | A directory no module output may create or replace. The @.seihou@ +-- directory itself is allowed: creating it when it exists is a no-op. +isControlDirectory :: FilePath -> Bool +isControlDirectory = isJust . controlPathReason DirectoryOperand + +-- | Why a path is refused as the given kind of operand, in user words, or +-- 'Nothing' when it is not control data. +controlPathReason :: PathOperand -> FilePath -> Maybe Text +controlPathReason operand path = case classifyProjectPath path of + ControlPath reason -> Just reason + SeihouRootDirectory + | operand == FileTarget -> Just "path names Seihou's state directory .seihou itself" + _ -> Nothing + +-- | 'Nothing' when the module named by the first argument may write (as a file +-- target) or create (as a directory operand) the path. A module may write under +-- @.seihou/@ only inside @.seihou//@, spelled exactly; any +-- other answer is a message that names the directory it may use. +ownStateDirectoryViolation :: Text -> PathOperand -> FilePath -> Maybe Text +ownStateDirectoryViolation moduleName operand path = case classifyProjectPath path of + OrdinaryProjectPath -> Nothing + ControlPath reason -> Just reason + SeihouRootDirectory + | operand == DirectoryOperand -> Nothing + | otherwise -> Just (T.pack path <> " is Seihou's state directory and cannot be written as a file") + ModuleStatePath area below + | ownSpelling && area == moduleName && (below || operand == DirectoryOperand) -> Nothing + | ownSpelling && area == moduleName -> + Just (T.pack path <> " is this module's state directory and cannot be written as a file") + | otherwise -> + Just + ( T.pack path + <> " is outside this module's state directory; a module may write under .seihou/ only inside " + <> ownDirectory + ) + where + ownSpelling = take 1 (controlSegments path) == [".seihou"] + ownDirectory = ".seihou/" <> moduleName <> "/" -- | Checkout declarations use a canonical, portable spelling and reserve metadata. -- This deliberately strengthens rather than changes the legacy validator above. diff --git a/src/Seihou/Core/Registry.hs b/src/Seihou/Core/Registry.hs --- a/src/Seihou/Core/Registry.hs +++ b/src/Seihou/Core/Registry.hs @@ -21,6 +21,7 @@ import Data.Generics.Labels () import Data.Text qualified as T +import Seihou.Core.ArtifactFiles (judgementAmbiguity, renderAmbiguousArtifact) import Seihou.Core.Types (ModuleLoadError, ModuleName (..)) import Seihou.Prelude import System.Directory (doesFileExist) @@ -43,7 +44,8 @@ modules :: ![RegistryEntry], recipes :: ![RegistryEntry], blueprints :: ![RegistryEntry], - prompts :: ![RegistryEntry] + prompts :: ![RegistryEntry], + judgements :: ![RegistryEntry] } deriving stock (Eq, Show, Generic) @@ -57,6 +59,8 @@ SingleBlueprint FilePath | -- | Repo root has @prompt.dhall@ (single prompt) SinglePrompt FilePath + | -- | Repo root has @judgement.dhall@ (single judgement) + SingleJudgement FilePath | -- | Repo root has @seihou-registry.dhall@ MultiModule Registry | -- | Neither found @@ -82,7 +86,9 @@ else probeSingleArtifact repoRoot -- | Probe for a single-artifact repo at @repoRoot@. Precedence: --- @module.dhall@ → @recipe.dhall@ → @blueprint.dhall@ → @prompt.dhall@ → 'EmptyRepo'. +-- @module.dhall@ → @recipe.dhall@ → @blueprint.dhall@ → @prompt.dhall@ → +-- @judgement.dhall@ → 'EmptyRepo'. A @judgement.dhall@ next to another +-- definition file is ambiguous; install rejects it when it inspects the root. -- A stray @module.dhall@ next to a @blueprint.dhall@ resolves as the -- module: the more specific, deterministic artifact wins. probeSingleArtifact :: FilePath -> IO RepoContents @@ -106,21 +112,59 @@ hasPrompt <- doesFileExist promptFile if hasPrompt then pure (SinglePrompt repoRoot) - else pure EmptyRepo + else do + hasJudgement <- doesFileExist (repoRoot "judgement.dhall") + pure (if hasJudgement then SingleJudgement repoRoot else EmptyRepo) -- | Validate a registry's entries against the filesystem. -- Returns a list of error messages (empty means valid). -- Checks: module name format, path safety, entry file existence, --- and no name collisions between modules, recipes, blueprints, and prompts. +-- no name collisions between modules, recipes, blueprints, prompts, and +-- judgements, and no entry directory whose @judgement.dhall@ shares it with +-- another definition file. validateRegistry :: FilePath -> Registry -> IO [Text] validateRegistry repoRoot reg = do modErrs <- concat <$> mapM (validateModuleEntry repoRoot) (reg ^. #modules) recErrs <- concat <$> mapM (validateRecipeEntry repoRoot) (reg ^. #recipes) bpErrs <- concat <$> mapM (validateBlueprintEntry repoRoot) (reg ^. #blueprints) promptErrs <- concat <$> mapM (validatePromptEntry repoRoot) (reg ^. #prompts) - let collisionErrs = checkNameCollisions (reg ^. #modules) (reg ^. #recipes) (reg ^. #blueprints) (reg ^. #prompts) - pure (modErrs <> recErrs <> bpErrs <> promptErrs <> collisionErrs) + judgementErrs <- concat <$> mapM (validateJudgementEntry repoRoot) (reg ^. #judgements) + ambiguityErrs <- concat <$> mapM (checkEntryAmbiguity repoRoot) (registryEntries reg) + let collisionErrs = + checkNameCollisions + [ ("module", reg ^. #modules), + ("recipe", reg ^. #recipes), + ("blueprint", reg ^. #blueprints), + ("prompt", reg ^. #prompts), + ("judgement", reg ^. #judgements) + ] + pure (modErrs <> recErrs <> bpErrs <> promptErrs <> judgementErrs <> ambiguityErrs <> collisionErrs) +-- | Every entry of every kind, in registry order, deduplicated by path so a +-- path listed twice is reported once. +registryEntries :: Registry -> [RegistryEntry] +registryEntries reg = dedupe (reg ^. #modules <> reg ^. #recipes <> reg ^. #blueprints <> reg ^. #prompts <> reg ^. #judgements) + where + dedupe = go [] + go _ [] = [] + go seen (e : rest) + | (e ^. #path) `elem` seen = go seen rest + | otherwise = e : go ((e ^. #path) : seen) rest + +-- | Report an entry directory where @judgement.dhall@ sits next to another +-- artifact definition file. Unsafe paths are skipped; the per-kind checks +-- already report them. +checkEntryAmbiguity :: FilePath -> RegistryEntry -> IO [Text] +checkEntryAmbiguity repoRoot entry + | unsafePath (T.pack (entry ^. #path)) = pure [] + | otherwise = do + ambiguity <- judgementAmbiguity (repoRoot entry ^. #path) + pure $ case ambiguity of + Nothing -> [] + Just files -> [renderAmbiguousArtifact (entry ^. #name) (entry ^. #path) files] + where + unsafePath p = T.isPrefixOf "/" p || ".." `T.isInfixOf` p + validateModuleEntry :: FilePath -> RegistryEntry -> IO [Text] validateModuleEntry repoRoot entry = do let nameText = (entry ^. #name . #unModuleName) @@ -213,28 +257,46 @@ | ".." `T.isInfixOf` path = ["registry prompt path must not contain '..': " <> path] | otherwise = [] --- | Detect name collisions across module, recipe, blueprint, and prompt entries. --- Each cross-kind pair sharing a name produces one message; a name that --- appears in all four kinds produces six messages (one per pair). -checkNameCollisions :: [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [Text] -checkNameCollisions mods recs bps prompts = - let modNames = map (\e -> e ^. #name . #unModuleName) mods - recNames = map (\e -> e ^. #name . #unModuleName) recs - bpNames = map (\e -> e ^. #name . #unModuleName) bps - promptNames = map (\e -> e ^. #name . #unModuleName) prompts - modRec = [n | n <- modNames, n `elem` recNames] - modBp = [n | n <- modNames, n `elem` bpNames] - modPrompt = [n | n <- modNames, n `elem` promptNames] - recBp = [n | n <- recNames, n `elem` bpNames] - recPrompt = [n | n <- recNames, n `elem` promptNames] - bpPrompt = [n | n <- bpNames, n `elem` promptNames] - in map (\n -> "name collision: '" <> n <> "' appears as both a module and a recipe") modRec - <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a blueprint") modBp - <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a prompt") modPrompt - <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a blueprint") recBp - <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a prompt") recPrompt - <> map (\n -> "name collision: '" <> n <> "' appears as both a blueprint and a prompt") bpPrompt +validateJudgementEntry :: FilePath -> RegistryEntry -> IO [Text] +validateJudgementEntry repoRoot entry = do + let nameText = (entry ^. #name . #unModuleName) + nameErrors = checkJudgementName nameText + pathText = T.pack (entry ^. #path) + pathErrors = checkJudgementPath pathText + let judgementDhall = repoRoot entry ^. #path "judgement.dhall" + fileExists <- doesFileExist judgementDhall + let fileErrors = + if fileExists + then [] + else ["registry judgement entry '" <> nameText <> "' points to missing judgement.dhall at " <> pathText] + pure (nameErrors <> pathErrors <> fileErrors) + where + checkJudgementName name + | validModuleName name = [] + | otherwise = ["registry judgement name must match [a-z][a-z0-9-]*, got: " <> name] + checkJudgementPath path + | T.isPrefixOf "/" path = ["registry judgement path must be relative: " <> path] + | ".." `T.isInfixOf` path = ["registry judgement path must not contain '..': " <> path] + | otherwise = [] + +-- | Detect name collisions across the entry kinds, given in display order. +-- Each cross-kind pair sharing a name produces one message, grouped by pair +-- in the order the kinds are given (module/recipe, module/blueprint, ...). +checkNameCollisions :: [(Text, [RegistryEntry])] -> [Text] +checkNameCollisions kinds = + [ "name collision: '" <> n <> "' appears as both a " <> kindA <> " and a " <> kindB + | (i, (kindA, as)) <- indexed, + (j, (kindB, bs)) <- indexed, + i < j, + let bNames = names bs, + n <- names as, + n `elem` bNames + ] + where + indexed = zip [0 :: Int ..] kinds + names = map (\e -> e ^. #name . #unModuleName) + -- | Check that a text matches @[a-z][a-z0-9-]*@. -- Duplicated from @Seihou.Core.Module.isValidModuleName@ to avoid -- a circular module dependency through @Seihou.Dhall.Eval@. @@ -246,7 +308,7 @@ && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-') rest -- | What a registry entry points at on disk. -data EntryKind = ModuleEntry | RecipeEntry | BlueprintEntry | PromptEntry +data EntryKind = ModuleEntry | RecipeEntry | BlueprintEntry | PromptEntry | JudgementEntry deriving stock (Eq, Show, Generic) -- | Classification of a single registry entry relative to the on-disk @@ -295,7 +357,7 @@ SyncReport computeRegistrySync reg lookups = SyncReport - { diffs = moduleDiffs <> recipeDiffs <> blueprintDiffs <> promptDiffs, + { diffs = moduleDiffs <> recipeDiffs <> blueprintDiffs <> promptDiffs <> judgementDiffs, updated = reg & #modules @@ -306,12 +368,15 @@ %~ zipWith applyDiff blueprintDiffs & #prompts %~ zipWith applyDiff promptDiffs + & #judgements + %~ zipWith applyDiff judgementDiffs } where moduleDiffs = map (classify ModuleEntry) (reg ^. #modules) recipeDiffs = map (classify RecipeEntry) (reg ^. #recipes) blueprintDiffs = map (classify BlueprintEntry) (reg ^. #blueprints) promptDiffs = map (classify PromptEntry) (reg ^. #prompts) + judgementDiffs = map (classify JudgementEntry) (reg ^. #judgements) classify :: EntryKind -> RegistryEntry -> SyncDiff classify kind entry = @@ -387,10 +452,12 @@ kindWord RecipeEntry = "recipe" kindWord BlueprintEntry = "blueprint" kindWord PromptEntry = "prompt" + kindWord JudgementEntry = "judgement" entryFile ModuleEntry = "module.dhall" entryFile RecipeEntry = "recipe.dhall" entryFile BlueprintEntry = "blueprint.dhall" entryFile PromptEntry = "prompt.dhall" + entryFile JudgementEntry = "judgement.dhall" -- | One row of the unified validation report. Either reuses an existing -- structural error message (path/name/file-existence/collisions) or @@ -407,7 +474,8 @@ moduleCount :: !Int, recipeCount :: !Int, blueprintCount :: !Int, - promptCount :: !Int + promptCount :: !Int, + judgementCount :: !Int } deriving stock (Eq, Show, Generic) @@ -438,7 +506,8 @@ moduleCount = length (reg ^. #modules), recipeCount = length (reg ^. #recipes), blueprintCount = length (reg ^. #blueprints), - promptCount = length (reg ^. #prompts) + promptCount = length (reg ^. #prompts), + judgementCount = length (reg ^. #judgements) } where isVersionDrift SyncMissing = True @@ -466,12 +535,14 @@ entryFile RecipeEntry = "recipe.dhall" entryFile BlueprintEntry = "blueprint.dhall" entryFile PromptEntry = "prompt.dhall" + entryFile JudgementEntry = "judgement.dhall" validationKindPrefix :: EntryKind -> Text validationKindPrefix ModuleEntry = "modules." validationKindPrefix RecipeEntry = "recipes." validationKindPrefix BlueprintEntry = "blueprints." validationKindPrefix PromptEntry = "prompts." +validationKindPrefix JudgementEntry = "judgements." validationRenderVersion :: Maybe Text -> Text validationRenderVersion Nothing = "(none)" @@ -493,6 +564,8 @@ renderEntryList (reg ^. #blueprints), ", prompts =", renderEntryList (reg ^. #prompts), + ", judgements =", + renderEntryList (reg ^. #judgements), "}" ] diff --git a/src/Seihou/Core/Scaffold.hs b/src/Seihou/Core/Scaffold.hs --- a/src/Seihou/Core/Scaffold.hs +++ b/src/Seihou/Core/Scaffold.hs @@ -5,6 +5,8 @@ examplePromptMarkdown, promptDhall, exampleAgentPromptMarkdown, + judgementDhall, + judgementExamplesJson, ) where @@ -202,4 +204,77 @@ "", "Ask before destructive changes such as deleting files, force-pushing,", "or rewriting history." + ] + +-- | A new judgement with one check whose rubric is meant to be edited in +-- the @instructions@ field, rather than a vacuous "review carefully". +judgementDhall :: Text -> Text -> Text -> Text +judgementDhall name url hash = + T.unlines + [ "let S =", + " " <> url, + " " <> hash, + "", + "-- A judgement asks a model yes/no questions about the staged changes before", + "-- each commit. Edit the instructions to describe what this project cares about", + "-- and what is acceptable, then add labelled cases to examples.json.", + "--", + "-- Every threshold applies to the probability of the concern: at or above", + "-- blockAt the check blocks, at or below passAt it may pass, and in between it", + "-- needs human review. concernWhen says which answer is the concern.", + "in S.Judgement::{", + " , name = \"" <> name <> "\"", + " , version = Some \"0.1.0\"", + " , description = Some \"Checks staged changes before each commit\"", + " , instructions =", + " ''", + " You review a change that is about to be committed. Decide only the", + " question you are asked; ignore style and unrelated problems.", + "", + " Acceptable: synthetic test data, documented examples and placeholders.", + " A concern: replace this line with what this project must not commit.", + " ''", + " , evidence = S.JudgementEvidence::{ scopes = [ S.EvidenceScope.StagedChanges, S.EvidenceScope.CommitRange ] }", + " , checks =", + " [ S.Check::{", + " , name = \"concern-present\"", + " , question = \"Does this change add something the instructions describe as a concern?\"", + " , yesMeans = Some \"At least one shown line matches a concern in the instructions.\"", + " , noMeans = Some \"Everything shown is acceptable under the instructions.\"", + " , categories =", + " [ S.FindingCategory::{", + " , name = \"concern\"", + " , severity = S.Severity.High", + " , description = Some \"A place where the concern appears\"", + " }", + " ]", + " , blockAt = 0.7", + " , passAt = 0.3", + " }", + " ]", + " }" + ] + +-- | Synthetic labelled cases for 'judgementDhall''s single check. +judgementExamplesJson :: Text +judgementExamplesJson = + T.unlines + [ "{", + " \"version\": 1,", + " \"examples\": [", + " {", + " \"id\": \"benign-docs\",", + " \"description\": \"A documentation edit with nothing the instructions call a concern\",", + " \"files\": [{ \"path\": \"README.md\", \"content\": \"# Demo\\n\\nRun make test before opening a pull request.\\n\" }],", + " \"expect\": { \"concern-present\": \"passed\" }", + " },", + " {", + " \"id\": \"replace-me-concern\",", + " \"description\": \"Replace with a synthetic change this judgement must block\",", + " \"files\": [{ \"path\": \"notes/todo.md\", \"content\": \"Replace this file with a synthetic example of the concern.\\n\" }],", + " \"expect\": { \"concern-present\": \"blocked\" },", + " \"findings\": [{ \"check\": \"concern-present\", \"category\": \"concern\", \"path\": \"notes/todo.md\", \"line\": 1 }]", + " }", + " ]", + "}" ] diff --git a/src/Seihou/Core/Types.hs b/src/Seihou/Core/Types.hs --- a/src/Seihou/Core/Types.hs +++ b/src/Seihou/Core/Types.hs @@ -45,6 +45,9 @@ AgentPrompt (..), Runnable (..), recipeNameToModuleName, + ActiveJudgement (..), + JudgementSource (..), + JudgementOwner (..), Operation (..), isAdditiveOperation, ModuleLoadError (..), @@ -99,6 +102,7 @@ import Data.Time (UTCTime) import GHC.Generics (Generic) import Numeric.Natural (Natural) +import Seihou.Core.Judgement (JudgementDefinition, JudgementPolicy) import Seihou.Core.Migration (BlueprintMigration, Migration) -- | A module identifier such as @"haskell-base"@. @@ -472,6 +476,7 @@ | RunnableRecipe Recipe FilePath | RunnableBlueprint Blueprint FilePath | RunnableAgentPrompt AgentPrompt FilePath + | RunnableJudgement JudgementDefinition FilePath deriving stock (Show) -- | Convert a 'RecipeName' to a 'ModuleName' (they share a namespace). @@ -541,6 +546,10 @@ | CircularDependency [ModuleName] | MissingSourceFile ModuleName FilePath | RegistryEvalError Text Text + | -- | An artifact directory holds a @judgement.dhall@ next to another + -- artifact definition file, so its kind is ambiguous. Carries the + -- requested name, the directory, and every definition file present. + AmbiguousArtifact ModuleName FilePath [FilePath] deriving stock (Eq, Show, Generic) -- | Tracks where a variable's value came from (for provenance / @--explain@). @@ -608,10 +617,45 @@ applications :: ![AppliedComposition], recipe :: !(Maybe AppliedRecipe), blueprint :: !(Maybe AppliedBlueprint), - blueprintMigrations :: ![AppliedBlueprintMigration] + blueprintMigrations :: ![AppliedBlueprintMigration], + -- | Active judgements: the resolved definition snapshot and the + -- project-owned policy for each, keyed by definition name. Introduced by + -- schema 15; older manifests decode with none. + judgements :: ![ActiveJudgement] } deriving stock (Eq, Show, Generic) +-- | Where an active judgement's definition was resolved from. +data JudgementSource + = -- | The catalogue compiled into the seihou binary. + BundledJudgement + | -- | An ordinary artifact found by discovery or installed from a registry. + ArtifactJudgement !ArtifactOrigin + deriving stock (Eq, Show, Generic) + +-- | One judgement a project has adopted. The definition is a snapshot, so a +-- later artifact or binary cannot silently change what is checked, and the +-- digest identifies the reviewed definition bytes. The policy is project +-- intent: the data policy and per-check enforcement and thresholds. +data ActiveJudgement = ActiveJudgement + { source :: !JudgementSource, + definition :: !JudgementDefinition, + digest :: !SHA256, + policy :: !JudgementPolicy, + -- | Who keeps the judgement active. The last owner's retirement removes + -- the record. + owners :: ![JudgementOwner] + } + deriving stock (Eq, Show, Generic) + +-- | One reason a judgement is active. +data JudgementOwner + = -- | Adopted directly with @seihou run NAME@. + DirectAdoption + | -- | Referenced by a recorded application's module or recipe. + ApplicationOwner !ApplicationId + deriving stock (Eq, Ord, Show, Generic) + -- | The numeric schema of @.seihou/manifest.json@. Every semantic change to -- the serialized manifest advances it (see -- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md). @@ -635,6 +679,8 @@ | SeedOwnerClaims | CheckoutLocalOutputs | CheckoutLocalCommands + | -- | Active judgement definitions and their policy (schema 15). + JudgementState deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) -- | What the manifest knows about how the owners of a path write it. diff --git a/src/Seihou/Dhall/Eval.hs b/src/Seihou/Dhall/Eval.hs --- a/src/Seihou/Dhall/Eval.hs +++ b/src/Seihou/Dhall/Eval.hs @@ -7,6 +7,10 @@ evalBlueprintFromFile, evalAgentPromptFromFile, evalRegistryFromFile, + evalJudgementFromFile, + evalJudgementFromText, + evalJudgementRefsFromFile, + judgementDecoder, moduleDecoder, recipeDecoder, blueprintDecoder, @@ -39,6 +43,7 @@ import Data.Either.Validation (Validation (..)) import Data.Generics.Labels () import Data.List (foldl') +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -47,10 +52,11 @@ import Dhall.Core (Chunks (..), makeRecordField, recordFieldValue) import Dhall.Core qualified as Dhall (Expr (..)) import Dhall.Map qualified as DhallMap -import Dhall.Marshal.Decode (Decoder (..), Extractor, bool, constructor, extractError, field, maybe, natural, string, union) +import Dhall.Marshal.Decode (Decoder (..), Extractor, bool, constructor, double, extractError, field, maybe, natural, string, union, unit) import Dhall.Pretty (prettyExpr) import Dhall.Src (Src) import Seihou.Core.Expr (parseExpr) +import Seihou.Core.Judgement qualified as J import Seihou.Core.Migration (BlueprintMigration (..), EntailedEdge (..), Migration (..), MigrationOp (..)) import Seihou.Core.Registry (Registry (..), RegistryEntry (..)) import Seihou.Core.Types @@ -256,15 +262,22 @@ -- | Decoder for a 'MigrationOp' from a Dhall union value. -- The union variants must match @schema/MigrationOp.dhall@. migrationOpDecoder :: Decoder MigrationOp -migrationOpDecoder = - union - ( (mkMoveFile <$> constructor "MoveFile" srcDestRecord) - <> (mkMoveDir <$> constructor "MoveDir" srcDestRecord) - <> (mkDeleteFile <$> constructor "DeleteFile" pathRecord) - <> (mkDeleteDir <$> constructor "DeleteDir" pathRecord) - <> (mkRunCommand <$> constructor "RunCommand" runCommandRecord) - ) +migrationOpDecoder = Decoder decode (expected extended) where + decode expr = case extract extended expr of + Success value -> Success value + Failure _ -> extract legacy expr + extended = union (variants <> (mkRemoveLine <$> constructor "RemoveLine" removeLineRecord)) + legacy = union variants + variants = + ( (mkMoveFile <$> constructor "MoveFile" srcDestRecord) + <> (mkMoveDir <$> constructor "MoveDir" srcDestRecord) + <> (mkDeleteFile <$> constructor "DeleteFile" pathRecord) + <> (mkDeleteDir <$> constructor "DeleteDir" pathRecord) + <> (mkRunCommand <$> constructor "RunCommand" runCommandRecord) + ) + removeLineRecord = record ((,) <$> field "path" string <*> field "line" strictText) + mkRemoveLine (p, l) = RemoveLine {path = p, line = l} srcDestRecord :: Decoder (FilePath, FilePath) srcDestRecord = record ((,) <$> field "src" string <*> field "dest" string) @@ -816,14 +829,15 @@ -- | Decoder for a registry metadata file from Dhall. -- Uses 'withDefaults' to handle registries that omit the @recipes@ or --- @blueprints@ or @prompts@ field (backwards compatibility with existing --- seihou-registry.dhall files). +-- @blueprints@ or @prompts@ or @judgements@ field (backwards compatibility +-- with existing seihou-registry.dhall files). registryDecoder :: Decoder Registry registryDecoder = withDefaults [ ("recipes", emptyRegistryEntryList), ("blueprints", emptyRegistryEntryList), - ("prompts", emptyRegistryEntryList) + ("prompts", emptyRegistryEntryList), + ("judgements", emptyRegistryEntryList) ] $ record ( Registry @@ -833,6 +847,7 @@ <*> field "recipes" (list registryEntryDecoder) <*> field "blueprints" (list registryEntryDecoder) <*> field "prompts" (list registryEntryDecoder) + <*> field "judgements" (list registryEntryDecoder) ) -- | A Dhall expression representing an empty list of registry entries. @@ -917,3 +932,145 @@ | not (null values) -> DhallMap.insert key (makeRecordField (Dhall.ListLit annotation (fmap edge values))) fields _ -> fields + +-- --------------------------------------------------------------------------- +-- Judgements + +-- | Evaluate a @judgement.dhall@ file and decode it into a +-- 'J.JudgementDefinition'. Structural validation ('J.validateDefinition') is +-- a separate step so a caller can name the failing part precisely. +evalJudgementFromFile :: FilePath -> IO (Either ModuleLoadError J.JudgementDefinition) +evalJudgementFromFile path = TIO.readFile path >>= evalJudgementFromText path + +-- | Evaluate judgement Dhall source text. Relative imports resolve against +-- the directory of the given path, which also names the source in errors; +-- the bundled catalogue passes self-contained text with a virtual path. +evalJudgementFromText :: FilePath -> Text -> IO (Either ModuleLoadError J.JudgementDefinition) +evalJudgementFromText path text = do + result <- try $ do + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract judgementDecoder expr of + Success d -> evaluate d + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> pure (Left (DhallEvalError (guessModuleName path) (T.pack (show e)))) + Right d -> pure (Right d) + +-- | Decoder for the top-level Judgement type. An empty @checks@ list is a +-- decode error: a judgement without a question cannot decide anything. +judgementDecoder :: Decoder J.JudgementDefinition +judgementDecoder = + record + ( J.JudgementDefinition + <$> field "name" strictText + <*> field "version" (maybe strictText) + <*> field "description" (maybe strictText) + <*> field "instructions" strictText + <*> field "evidence" evidenceDecoder + <*> field "limits" limitsDecoder + <*> field "deterministicChecks" (list deterministicDecoder) + <*> field "checks" (nonEmptyList "a judgement needs at least one check" checkDecoder) + ) + where + nonEmptyList msg (Decoder ext ty) = + let Decoder lext lty = list (Decoder ext ty) + in Decoder + ( \e -> case lext e of + Success xs -> case NE.nonEmpty xs of + Just ne -> Success ne + Nothing -> extractError msg + Failure err -> Failure err + ) + lty + evidenceDecoder = + record + ( J.EvidenceDeclaration + <$> field "scopes" (list scopeDecoder) + <*> field "include" (list strictText) + <*> field "exclude" (list strictText) + ) + scopeDecoder = + union + ( (J.StagedChangesScope <$ constructor "StagedChanges" unit) + <> (J.CommitRangeScope <$ constructor "CommitRange" unit) + ) + deterministicDecoder = union (J.SecretScan <$ constructor "SecretScan" unit) + limitsDecoder = + record + ( J.CoverageLimits + <$> field "maxFileBytes" int + <*> field "maxChunkBytes" int + <*> field "maxChunks" int + <*> field "maxAttempts" int + <*> field "timeoutSeconds" int + <*> field "maxFindings" int + ) + int = fromIntegral . min (fromIntegral (maxBound :: Int)) <$> natural + answerDecoder = union ((J.Yes <$ constructor "Yes" unit) <> (J.No <$ constructor "No" unit)) + enforcementDecoder = + union ((J.Enforced <$ constructor "Enforced" unit) <> (J.Advisory <$ constructor "Advisory" unit)) + severityDecoder = + union + ( (J.Info <$ constructor "Info" unit) + <> (J.Low <$ constructor "Low" unit) + <> (J.Medium <$ constructor "Medium" unit) + <> (J.High <$ constructor "High" unit) + <> (J.Critical <$ constructor "Critical" unit) + ) + categoryDecoder = + record + ( J.FindingCategory + <$> field "name" strictText + <*> field "severity" severityDecoder + <*> field "description" (maybe strictText) + ) + checkDecoder = + record + ( mkCheck + <$> field "name" strictText + <*> field "question" strictText + <*> field "concernWhen" answerDecoder + <*> field "yesMeans" (maybe strictText) + <*> field "noMeans" (maybe strictText) + <*> field "categories" (list categoryDecoder) + <*> field "enforcement" enforcementDecoder + <*> field "blockingSeverity" severityDecoder + <*> field "blockAt" double + <*> field "passAt" double + <*> field "gateBlockAt" double + <*> field "gatePassAt" double + <*> field "useGate" bool + ) + mkCheck n q c y no cats enf sev bAt pAt gbAt gpAt useGate = + J.JudgementCheck n q c y no cats enf sev (J.Thresholds bAt pAt) (J.Thresholds gbAt gpAt) useGate + +-- | The @judgements@ references of a @module.dhall@ or @recipe.dhall@. The +-- field is decoded on its own, so artifacts written against a schema pin +-- without it decode with none, and the module and recipe records stay as +-- they are. +evalJudgementRefsFromFile :: FilePath -> IO (Either ModuleLoadError [J.JudgementRef]) +evalJudgementRefsFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract decoder expr of + Success refs -> evaluate refs + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> pure (Left (DhallEvalError (guessModuleName path) (T.pack (show e)))) + Right refs -> pure (Right refs) + where + decoder = withDefaults [("judgements", Dhall.ListLit (Just (Dhall.Record mempty)) mempty)] (record (field "judgements" (list refDecoder))) + refDecoder = + record + ( J.JudgementRef + <$> field "name" strictText + <*> field "source" (maybe strictText) + <*> field "when" (maybe strictText) + ) diff --git a/src/Seihou/Engine/Migrate.hs b/src/Seihou/Engine/Migrate.hs --- a/src/Seihou/Engine/Migrate.hs +++ b/src/Seihou/Engine/Migrate.hs @@ -9,12 +9,15 @@ classifyMigration, executeMigration, validateSeedMigration, + removeExactLine, ) where +import Control.Monad (when) import Data.Generics.Labels () import Data.List (nub, sortBy) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) import Data.Set qualified as Set import Data.Text qualified as T @@ -25,7 +28,7 @@ MigrationOp (..), MigrationPlan (..), ) -import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), controlPathReason, pathsHaveConflictingSpelling, validateProjectRelativePath) import Seihou.Core.Types ( AppliedModule (..), FileRecord (..), @@ -35,13 +38,16 @@ import Seihou.Core.Version (renderVersion) import Seihou.Effect.Filesystem ( Filesystem, + PathEntry (..), createDirectoryIfMissing, doesFileExist, + inspectPath, readFileText, removeDirectoryIfEmpty, removeDirectoryRecursive, removeFile, renamePath, + writeFileText, ) import Seihou.Effect.Process (Process, runProcess) import Seihou.Manifest.Hash (hashContent) @@ -75,6 +81,7 @@ | MoveDirInst FilePath FilePath | DeleteFileInst FilePath MigrationFileStatus | DeleteDirInst FilePath + | RemoveLineInst FilePath Text | RunCommandInst Text (Maybe FilePath) deriving stock (Eq, Show, Generic) @@ -157,14 +164,33 @@ case validateMigrationPath "delete-dir path" path of Left err -> Left err Right safePath -> Right (DeleteDirInst safePath) + RemoveLine {path, line} -> pure $ do + safePath <- validateMigrationPath "remove-line path" path + if T.null line || T.any (`elem` ['\r', '\n']) line + then Left (MigrationUnsafePath "remove-line line" path "line must be nonempty and contain no newline") + else Right (RemoveLineInst safePath line) RunCommand {run, workDir} -> pure $ - case traverse (validateMigrationPath "run-command workDir") workDir of + case traverse (validateMigrationWorkDir "run-command workDir") workDir of Left err -> Left err Right safeWorkDir -> Right (RunCommandInst run safeWorkDir) +-- | Validate a path a migration moves, deletes or creates. It must stay in the +-- project and must not name Seihou's or Git's control data or the @.seihou@ +-- directory itself. Unlike generation, a migration may touch any other entry +-- under @.seihou/@, so it can move a legacy @.seihou/.conf@ into the +-- module's own @.seihou//@ directory. validateMigrationPath :: Text -> FilePath -> Either MigrationExecError FilePath -validateMigrationPath label path = +validateMigrationPath label path = do + safePath <- validateMigrationWorkDir label path + case controlPathReason FileTarget safePath of + Just reason -> Left (MigrationUnsafePath label path reason) + Nothing -> Right safePath + +-- | A command's working directory need only stay in the project: the command +-- itself can already reach any file. +validateMigrationWorkDir :: Text -> FilePath -> Either MigrationExecError FilePath +validateMigrationWorkDir label path = case validateProjectRelativePath (T.pack path) of Left reason -> Left (MigrationUnsafePath label path reason) Right safePath -> Right safePath @@ -221,6 +247,7 @@ instancePaths (MoveDirInst source dest) = [source, dest] instancePaths (DeleteFileInst path _) = [path] instancePaths (DeleteDirInst path) = [path] + instancePaths (RemoveLineInst path _) = [path] instancePaths RunCommandInst {} = [] executeUnprotectedMigration :: (Filesystem :> es, Process :> es) => Bool -> ExecutedMigrationPlan -> Manifest -> UTCTime -> Eff es (Either MigrationExecError Manifest) @@ -296,6 +323,17 @@ DeleteDirInst p -> do removeDirectoryRecursive p runOps rest (dropDirFromManifest p manifest) (p : acc) + RemoveLineInst path line -> do + safe <- validateEditablePath path + case safe of + Left err -> pure (Left err) + Right () -> do + exists <- doesFileExist path + when exists $ do + content <- readFileText path + let edited = removeExactLine line content + when (edited /= content) (writeFileText path edited) + runOps rest manifest acc RunCommandInst run mWorkDir -> do (code, _stdout, stderr) <- runProcess "/bin/sh" ["-c", run] mWorkDir case code of @@ -395,9 +433,35 @@ paths MoveDir {src, dest} = [src, dest] paths DeleteFile {path} = [path] paths DeleteDir {path} = [path] + paths RemoveLine {path} = [path] paths RunCommand {} = [] validateProtectedMutationPaths :: Set FilePath -> [FilePath] -> Either MigrationExecError () validateProtectedMutationPaths seeds paths = case [path | path <- paths, seed <- Set.toAscList seeds, pathsOverlap (P.normalise path) (P.normalise seed) || pathsHaveConflictingSpelling (P.normalise path) (P.normalise seed)] of path : _ -> Left (MigrationUnsafePath "seed ownership" path "declarative migrations must not mutate a project-owned seed or a path being released to the project; publish a compatible producer migration") [] -> Right () + +-- | Remove matching logical lines without rewriting surviving terminators. +removeExactLine :: Text -> Text -> Text +removeExactLine target = go + where + go content + | T.null content = "" + | otherwise = + let (payload, suffix) = T.breakOn "\n" content + logical = if T.null suffix then payload else fromMaybe payload (T.stripSuffix "\r" payload) + kept = if logical == target then "" else payload <> if T.null suffix then "" else "\n" + in kept <> if T.null suffix then "" else go (T.drop 1 suffix) + +-- Inspect every component without following links, including parent directories. +validateEditablePath :: (Filesystem :> es) => FilePath -> Eff es (Either MigrationExecError ()) +validateEditablePath path = go (reverse (path : allParents path)) + where + go [] = pure (Right ()) + go (component : rest) = do + entry <- inspectPath component + case entry of + EntryMissing -> pure (Right ()) + EntryDirectory | component /= path -> go rest + EntryFile | component == path -> go rest + _ -> pure (Left (MigrationUnsafePath "remove-line path" path "target must be a regular file with no symbolic-link components")) diff --git a/src/Seihou/Engine/Plan.hs b/src/Seihou/Engine/Plan.hs --- a/src/Seihou/Engine/Plan.hs +++ b/src/Seihou/Engine/Plan.hs @@ -23,7 +23,7 @@ import Seihou.Core.Checkout (CheckoutError (..), pathsOverlap, validateCheckoutPaths) import Seihou.Core.Expr (evalExpr) import Seihou.Core.Module (checkCheckoutSteps, checkSeedSteps) -import Seihou.Core.Path (validateCanonicalProjectPath, validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), ownStateDirectoryViolation, validateCanonicalProjectPath, validateProjectRelativePath) import Seihou.Core.Types import Seihou.Engine.DhallJSON (dhallExprToJSON) import Seihou.Engine.Template (renderCommand, renderDestPath, renderTemplate, renderTemplateText) @@ -134,10 +134,10 @@ compileActiveStep = case step ^. #patch of Just _ -> compilePatchStep baseDir vars modName step Nothing -> case step ^. #strategy of - Copy -> compileCopyStep baseDir vars step - Template -> compileTemplateStep baseDir vars step - DhallText -> compileDhallTextStep baseDir vars step - Structured -> compileStructuredStep baseDir vars step + Copy -> compileCopyStep baseDir modName vars step + Template -> compileTemplateStep baseDir modName vars step + DhallText -> compileDhallTextStep baseDir modName vars step + Structured -> compileStructuredStep baseDir modName vars step Symlink -> pure $ case (renderCommand (T.pack (step ^. #src)) vars, renderCommand (step ^. #dest) vars) of (Right source, Right dest) -> case validateCheckoutPaths (T.unpack source) (T.unpack dest) of Left err -> Left [err ^. #message] @@ -148,10 +148,11 @@ -- | Compile a Copy step: read the source file and write it to the destination. compileCopyStep :: FilePath -> + ModuleName -> Map VarName VarValue -> Step -> IO (Either [Text] [Operation]) -compileCopyStep baseDir vars step = do +compileCopyStep baseDir modName vars step = do let srcPath = baseDir "files" (step ^. #src) result <- tryReadFile srcPath case result of @@ -161,15 +162,16 @@ Left placeholderErrors -> pure (Left (map formatPlaceholderError placeholderErrors)) Right dest -> - pure (writeFileOps dest content Copy) + pure (writeFileOps modName dest content Copy) -- | Compile a Template step: read, render placeholders, write. compileTemplateStep :: FilePath -> + ModuleName -> Map VarName VarValue -> Step -> IO (Either [Text] [Operation]) -compileTemplateStep baseDir vars step = do +compileTemplateStep baseDir modName vars step = do let srcPath = baseDir "files" (step ^. #src) result <- tryReadFile srcPath case result of @@ -183,15 +185,16 @@ Left placeholderErrors -> pure (Left (map formatPlaceholderError placeholderErrors)) Right dest -> - pure (writeFileOps dest rendered Template) + pure (writeFileOps modName dest rendered Template) -- | Compile a DhallText step: read source, substitute placeholders, evaluate as Dhall. compileDhallTextStep :: FilePath -> + ModuleName -> Map VarName VarValue -> Step -> IO (Either [Text] [Operation]) -compileDhallTextStep baseDir vars step = do +compileDhallTextStep baseDir modName vars step = do let srcPath = baseDir "files" (step ^. #src) result <- tryReadFile srcPath case result of @@ -209,16 +212,17 @@ Left placeholderErrors -> pure (Left (map formatPlaceholderError placeholderErrors)) Right dest -> - pure (writeFileOps dest evaluated DhallText) + pure (writeFileOps modName dest evaluated DhallText) -- | Compile a Structured step: read source, substitute placeholders, evaluate as Dhall, -- then serialize to JSON or YAML based on the destination file extension. compileStructuredStep :: FilePath -> + ModuleName -> Map VarName VarValue -> Step -> IO (Either [Text] [Operation]) -compileStructuredStep baseDir vars step = do +compileStructuredStep baseDir modName vars step = do let srcPath = baseDir "files" (step ^. #src) result <- tryReadFile srcPath case result of @@ -239,12 +243,12 @@ Left placeholderErrors -> pure (Left (map formatPlaceholderError placeholderErrors)) Right dest -> - case validateRenderedDestination dest of + case validateRenderedDestination modName dest of Left err -> pure (Left [err]) Right safeDest -> case serializeByExtension (T.unpack safeDest) jsonValue of Left err -> pure (Left [err]) - Right serialized -> pure (Right (writeFileOpsUnchecked safeDest serialized Structured)) + Right serialized -> pure (first pure (writeFileOpsUnchecked modName safeDest serialized Structured)) -- | Compile a patch step: read source, render template, produce PatchFileOp. -- The content rendering follows the step's strategy (Template renders placeholders, @@ -318,38 +322,52 @@ pure (Left ("Dhall evaluation failed: " <> T.pack (show e))) Right t -> pure (Right t) -validateRenderedDestination :: Text -> Either Text Text -validateRenderedDestination dest = +-- | Validate a rendered step destination as a file the module writes. Beyond +-- staying inside the project, a module may write under @.seihou/@ only inside +-- @.seihou//@ and never into Seihou's or Git's control data. +-- See docs/adr/0025-a-module-owns-only-its-own-directory-under-seihou.md. +validateRenderedDestination :: ModuleName -> Text -> Either Text Text +validateRenderedDestination modName dest = case validateProjectRelativePath dest of Left err -> Left ("rendered destination " <> err) - Right safePath -> Right (T.pack safePath) + Right safePath -> case ownStateDirectoryViolation (modName ^. #unModuleName) FileTarget safePath of + Just violation -> Left ("step destination " <> violation) + Nothing -> Right (T.pack safePath) +-- | The 'CreateDirOp's for a validated destination's parent directories, each +-- checked as a directory operand of the module. +parentDirOps :: ModuleName -> Text -> Either Text [Operation] +parentDirOps modName dest = traverse checked (parentDirs dest) + where + checked dir = case ownStateDirectoryViolation (modName ^. #unModuleName) DirectoryOperand (T.unpack dir) of + Just violation -> Left ("step directory " <> violation) + Nothing -> Right (CreateDirOp (T.unpack dir)) + validateRenderedCommandWorkDir :: Text -> Either Text Text validateRenderedCommandWorkDir workDir = case validateProjectRelativePath workDir of Left err -> Left ("rendered command workDir " <> err) Right safePath -> Right (T.pack safePath) -writeFileOps :: Text -> Text -> Strategy -> Either [Text] [Operation] -writeFileOps dest content strategy = - case validateRenderedDestination dest of +writeFileOps :: ModuleName -> Text -> Text -> Strategy -> Either [Text] [Operation] +writeFileOps modName dest content strategy = + case validateRenderedDestination modName dest of Left err -> Left [err] - Right safeDest -> Right (writeFileOpsUnchecked safeDest content strategy) + Right safeDest -> first pure (writeFileOpsUnchecked modName safeDest content strategy) -writeFileOpsUnchecked :: Text -> Text -> Strategy -> [Operation] -writeFileOpsUnchecked dest content strategy = - let destStr = T.unpack dest - dirOps = map (CreateDirOp . T.unpack) (parentDirs dest) - in dirOps ++ [WriteFileOp destStr content strategy] +-- | Operations for a destination 'validateRenderedDestination' already accepted. +writeFileOpsUnchecked :: ModuleName -> Text -> Text -> Strategy -> Either Text [Operation] +writeFileOpsUnchecked modName dest content strategy = do + dirOps <- parentDirOps modName dest + pure (dirOps ++ [WriteFileOp (T.unpack dest) content strategy]) patchFileOps :: Text -> Text -> PatchOp -> Strategy -> ModuleName -> Either [Text] [Operation] patchFileOps dest content patchOp' strategy modName = - case validateRenderedDestination dest of + case validateRenderedDestination modName dest of Left err -> Left [err] - Right safeDest -> - let destStr = T.unpack safeDest - dirOps = map (CreateDirOp . T.unpack) (parentDirs safeDest) - in Right (dirOps ++ [PatchFileOp destStr content patchOp' strategy modName]) + Right safeDest -> do + dirOps <- first pure (parentDirOps modName safeDest) + Right (dirOps ++ [PatchFileOp (T.unpack safeDest) content patchOp' strategy modName]) -- | Extract parent directories from a path. -- @"src/Lib.hs"@ produces @["src"]@. diff --git a/src/Seihou/Engine/Reconcile.hs b/src/Seihou/Engine/Reconcile.hs --- a/src/Seihou/Engine/Reconcile.hs +++ b/src/Seihou/Engine/Reconcile.hs @@ -19,6 +19,7 @@ resolveFileConflict, resolveEditedOrphan, reconciliationSummary, + reconciliationDifferences, reconciliationMutationPaths, unresolvedPaths, recordedSharedWriteMode, @@ -34,7 +35,7 @@ import Data.Text qualified as T import Data.Time (UTCTime) import Seihou.Core.Checkout (pathsOverlap) -import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), controlPathReason, pathsHaveConflictingSpelling, validateProjectRelativePath) import Seihou.Core.Seed (seedApplicationIds) import Seihou.Core.Types hiding (KeepCurrent) import Seihou.Effect.BaselineStore (BaselineError, BaselineStore, readBaseline) @@ -390,8 +391,8 @@ validateInputs selected operations ownerMap manifest = do let grouped = groupFileOperations operations directories = Set.fromList [path | CreateDirOp path <- operations] - traverse_ validateManagedPath (Map.keys grouped) - traverse_ validateManagedPath (Set.toList directories) + traverse_ (validateManagedPath FileTarget) (Map.keys grouped) + traverse_ (validateManagedPath DirectoryOperand) (Set.toList directories) traverse_ (validateOwner selected ownerMap manifest) (Map.toList grouped) pure (grouped, directories) @@ -427,26 +428,21 @@ | record ^. #sharedWriteMode == SharedWriteAdditiveOnly && all isAdditiveOperation pathOperations -> Right () | otherwise -> Left (SharedPathRequiresApplications path (record ^. #applicationIds)) -validateManagedPath :: FilePath -> Either ReconciliationError () -validateManagedPath rawPath = case validateProjectRelativePath (T.pack rawPath) of +-- | Refuse paths that leave the project or name Seihou's or Git's control data. +-- A module's own directory under @.seihou/@ is an ordinary managed location; +-- the @.seihou@ directory itself may be created but never written as a file. +validateManagedPath :: PathOperand -> FilePath -> Either ReconciliationError () +validateManagedPath operand rawPath = case validateProjectRelativePath (T.pack rawPath) of Left err -> Left (InvalidReconciliationPath rawPath err) Right safePath | safePath /= rawPath -> Left (InvalidReconciliationPath rawPath "path must not contain surrounding whitespace") | safePath == "." -> Left (InvalidReconciliationPath rawPath "path must name a project file or directory") - | targetsControlPath safePath -> - Left (InvalidReconciliationPath rawPath "path targets Seihou or Git control data") + | Just reason <- controlPathReason operand safePath -> + Left (InvalidReconciliationPath rawPath reason) | otherwise -> Right () -targetsControlPath :: FilePath -> Bool -targetsControlPath path = case pathSegments path of - firstSegment : _ -> firstSegment == ".seihou" || firstSegment == ".git" - [] -> False - -pathSegments :: FilePath -> [Text] -pathSegments = filter (not . T.null) . T.split (\character -> character == '/' || character == '\\') . T.pack - groupFileOperations :: [Operation] -> Map FilePath [Operation] groupFileOperations = foldl' addOperation Map.empty where @@ -762,3 +758,58 @@ unresolved (FileConflict _ _ _ _ _ _ Nothing) = True unresolved (FileOrphanEdited _ _ _ _ Nothing) = True unresolved _ = False + +-- | Explain exact plan inequality without disclosing file contents or hashes. +-- This is diagnostic only: callers must continue comparing complete plans. +reconciliationDifferences :: ReconciliationPlan -> ReconciliationPlan -> Map FilePath [Text] +reconciliationDifferences planned actual = + Map.fromList + [ (path, categories before after) + | path <- Set.toAscList (Map.keysSet (planned ^. #files) `Set.union` Map.keysSet (actual ^. #files)), + let before = Map.lookup path (planned ^. #files), + let after = Map.lookup path (actual ^. #files), + before /= after + ] + `Map.union` Map.fromSet (const ["metadata"]) directoryChanges + where + directoryChanges = ((planned ^. #requiredDirectories) Set.\\ (actual ^. #requiredDirectories)) `Set.union` ((actual ^. #requiredDirectories) Set.\\ (planned ^. #requiredDirectories)) + categories before after = + let changes = + ["classification" | fmap classification before /= fmap classification after] + <> ["observed content" | fmap observation before /= fmap observation after] + <> ["planned output" | fmap output before /= fmap output after] + in if null changes then ["metadata"] else changes + classification = \case + FileCreate {} -> "create" :: Text + FileUpdate {} -> "update" + FileAutoMerge {} -> "auto-merge" + FileUnchanged {} -> "unchanged" + FileConflict {} -> "conflict" + FileDeleteSafe {} -> "delete" + FileOrphanEdited {} -> "edited-orphan" + FileReleaseSharedOwnership {} -> "release-shared-ownership" + FileAlreadyAbsent {} -> "already-absent" + FileSeedCreate {} -> "seed-create" + FileSeedSettle {} -> "seed-settle" + FileSeedRelease {} -> "seed-release" + FileSeedAbandon {} -> "seed-abandon" + observation = \case + FileCreate _ _ observed -> Just observed + FileUpdate _ _ observed _ -> Just observed + FileAutoMerge _ _ observed _ -> Just observed + FileUnchanged _ _ observed _ -> Just observed + FileConflict _ _ _ _ observed _ _ -> Just observed + FileDeleteSafe _ _ observed -> Just observed + FileOrphanEdited _ _ _ observed _ -> Just observed + FileReleaseSharedOwnership _ _ observed -> Just observed + FileAlreadyAbsent _ _ observed -> Just observed + _ -> Nothing + output = \case + FileCreate desired state _ -> Just (desired ^. #generatedContent, state ^. #appliedContent) + FileUpdate desired state _ _ -> Just (desired ^. #generatedContent, state ^. #appliedContent) + FileAutoMerge desired state _ _ -> Just (desired ^. #generatedContent, state ^. #appliedContent) + FileUnchanged desired state _ _ -> Just (desired ^. #generatedContent, state ^. #appliedContent) + FileConflict desired current _ _ _ _ _ -> Just (desired ^. #generatedContent, current) + FileOrphanEdited _ _ current _ _ -> Just ("", current) + FileSeedCreate action _ -> ("",) <$> action ^. #newContent + _ -> Nothing diff --git a/src/Seihou/Engine/Remove.hs b/src/Seihou/Engine/Remove.hs --- a/src/Seihou/Engine/Remove.hs +++ b/src/Seihou/Engine/Remove.hs @@ -29,7 +29,7 @@ import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Core.Checkout import Seihou.Core.Expr (settleRemovalConditions) -import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), controlPathReason, pathsHaveConflictingSpelling, validateProjectRelativePath) import Seihou.Core.Seed import Seihou.Core.Types import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText, removeDirectoryIfEmpty, removeFile, writeFileText) @@ -220,12 +220,23 @@ buildCommandOp :: Command -> Either RemovalError RemovalOp buildCommandOp command | command ^. #lifecycle == CheckoutCommandLifecycle = Left (RemovalUnsafePath "remove-command" "" "checkout setup is not a removal command") - | otherwise = case traverse (validateRemovalPath "remove-command workDir") (command ^. #workDir) of + | otherwise = case traverse (validateRemovalWorkDir "remove-command workDir") (command ^. #workDir) of Left err -> Left err Right safeWorkDir -> Right (RemovalCommandOp (command ^. #run) (fmap T.pack safeWorkDir)) +-- | Validate a path a removal step deletes, strips or rewrites. It must stay in +-- the project and must not name Seihou's or Git's control data or the +-- @.seihou@ directory itself. validateRemovalPath :: Text -> Text -> Either RemovalError FilePath -validateRemovalPath label path = +validateRemovalPath label path = do + safePath <- validateRemovalWorkDir label path + case controlPathReason FileTarget safePath of + Just reason -> Left (RemovalUnsafePath label path reason) + Nothing -> Right safePath + +-- | A command's working directory need only stay in the project. +validateRemovalWorkDir :: Text -> Text -> Either RemovalError FilePath +validateRemovalWorkDir label path = case validateProjectRelativePath path of Left reason -> Left (RemovalUnsafePath label path reason) Right safePath -> Right safePath diff --git a/src/Seihou/Engine/UpdateTransaction.hs b/src/Seihou/Engine/UpdateTransaction.hs --- a/src/Seihou/Engine/UpdateTransaction.hs +++ b/src/Seihou/Engine/UpdateTransaction.hs @@ -32,7 +32,7 @@ import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Data.Time (UTCTime, getCurrentTime) -import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Path (PathOperand (..), controlPathReason, validateProjectRelativePath) import Seihou.Core.Seed (renderSeedOwnershipError, replaceSelectedSeedClaims) import Seihou.Core.Types import Seihou.Effect.BaselineStore (putBaseline) @@ -191,7 +191,8 @@ pure (JournalEntry relativePath (Just backupName) Nothing) EntryMissing -> pure (JournalEntry relativePath Nothing Nothing) EntryDirectory -> ioError (userError ("transaction target is a directory: " <> relativePath)) - -- The manifest is never a target (validateTransactionPath rejects .seihou/), + -- The manifest is never a target (validateTransactionPath rejects Seihou's + -- own state under .seihou/), -- but an orchestrator may publish it before the transaction commits. A byte -- copy lets rollback and crash recovery return it to this exact state. verifySafeParents (transaction ^. #projectRoot) manifestRelativePath @@ -343,7 +344,7 @@ Right () -> pure (Right candidate) transactionPreflight :: UpdateTransaction -> ReconciliationPlan -> IO (Either TransactionError ()) -transactionPreflight transaction plan = case traverse validateTransactionPath (Set.toAscList (plan ^. #requiredDirectories)) of +transactionPreflight transaction plan = case traverse validateTransactionDirectory (Set.toAscList (plan ^. #requiredDirectories)) of Left err -> pure (Left err) Right _ | not (Set.null unjournaled) -> pure (Left (TransactionUnjournaledPaths unjournaled)) @@ -508,7 +509,8 @@ blueprint = manifest ^. #blueprint, seeds = manifest ^. #seeds, checkoutOutputs = manifest ^. #checkoutOutputs, - blueprintMigrations = manifest ^. #blueprintMigrations + blueprintMigrations = manifest ^. #blueprintMigrations, + judgements = manifest ^. #judgements } writeBaselineBlob :: FilePath -> Text -> IO BaselineRef @@ -872,7 +874,7 @@ traverse_ validateBackupName [name | JournalEntry _ (Just name) _ <- metadata ^. #entries] traverse_ validateBackupName (metadata ^. #manifestBackup) traverse_ validateBaselineName (metadata ^. #setAsideBaselines) - traverse_ (first renderTransactionPathError . validateTransactionPath) (metadata ^. #newDirectories) + traverse_ (first renderTransactionPathError . validateTransactionDirectory) (metadata ^. #newDirectories) pure metadata where validateObjectId oid @@ -900,23 +902,25 @@ journalPath :: FilePath -> FilePath journalPath transactionDirectory = transactionDirectory "journal.json" +-- | Validate a file the transaction journals, writes, or restores. validateTransactionPath :: FilePath -> Either TransactionError FilePath -validateTransactionPath rawPath = case validateProjectRelativePath (T.pack rawPath) of +validateTransactionPath = validateTransactionOperand FileTarget + +-- | Validate a directory the transaction creates and may remove on rollback. +-- The @.seihou@ directory itself is allowed: it always exists while a +-- transaction does, so it is never recorded as newly created. +validateTransactionDirectory :: FilePath -> Either TransactionError FilePath +validateTransactionDirectory = validateTransactionOperand DirectoryOperand + +validateTransactionOperand :: PathOperand -> FilePath -> Either TransactionError FilePath +validateTransactionOperand operand rawPath = case validateProjectRelativePath (T.pack rawPath) of Left err -> Left (InvalidTransactionPath rawPath err) Right safePath | safePath /= rawPath -> Left (InvalidTransactionPath rawPath "path must not contain surrounding whitespace") | safePath == "." -> Left (InvalidTransactionPath rawPath "path must name a project file") - | targetsControlPath safePath -> - Left (InvalidTransactionPath rawPath "path targets Seihou or Git control data") + | Just reason <- controlPathReason operand safePath -> + Left (InvalidTransactionPath rawPath reason) | otherwise -> Right safePath - -targetsControlPath :: FilePath -> Bool -targetsControlPath path = case pathSegments path of - firstSegment : _ -> firstSegment == ".seihou" || firstSegment == ".git" - [] -> False - -pathSegments :: FilePath -> [Text] -pathSegments = filter (not . T.null) . T.split (\character -> character == '/' || character == '\\') . T.pack atomicWriteText :: FilePath -> Text -> IO () atomicWriteText path content = do diff --git a/src/Seihou/Engine/Validate.hs b/src/Seihou/Engine/Validate.hs --- a/src/Seihou/Engine/Validate.hs +++ b/src/Seihou/Engine/Validate.hs @@ -23,6 +23,7 @@ checkDestVarRefs, checkExportRefs, checkFileExistence, + checkModuleStateDestinations, checkNameFormat, checkPromptRefs, checkSafeDestinations, @@ -78,6 +79,7 @@ DiagCheck "Source file existence" DiagError fileErrors, DiagCheck "Dependency names" DiagError (checkDependencyNames m), DiagCheck "Safe step destinations" DiagError (checkSafeDestinations m), + DiagCheck "Module state destinations" DiagError (checkModuleStateDestinations m), DiagCheck "Checkout steps" DiagError (checkCheckoutSteps m), DiagCheck "Seed steps" DiagError (checkSeedSteps m), DiagCheck "Destination variable references" DiagError (checkDestVarRefs m), diff --git a/src/Seihou/Manifest/Judgement.hs b/src/Seihou/Manifest/Judgement.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Manifest/Judgement.hs @@ -0,0 +1,184 @@ +-- | The manifest encoding of judgement definitions and judgement policy. +-- +-- The encoding is Seihou's own and is versioned by the manifest schema +-- (introduced in schema 15). No provider, Shikumi or transport type appears +-- in it: thresholds are plain numbers, enumerations are stable kebab-case +-- strings, and every key is always written so a diff is reviewable. +-- +-- 'definitionDigest' hashes the canonical encoding of a definition, so the +-- digest identifies exactly the reviewed definition independently of the +-- Dhall source it was decoded from. +module Seihou.Manifest.Judgement + ( definitionToJSON, + parseDefinition, + policyToJSON, + parsePolicy, + definitionDigest, + ) +where + +import Control.Monad (forM_, unless) +import Data.Aeson (Value, object, withObject, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Seihou.Core.Judgement +import Seihou.Core.Types (SHA256) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude hiding ((.=)) + +-- | SHA-256 of the canonical encoding. Aeson writes object keys in sorted +-- order, so the bytes do not depend on construction order. +definitionDigest :: JudgementDefinition -> SHA256 +definitionDigest = hashContent . TE.decodeUtf8 . LBS.toStrict . Aeson.encode . definitionToJSON + +enumText :: (Bounded a, Enum a) => (a -> Text) -> Text -> Text -> Parser a +enumText render what t = case [x | x <- [minBound .. maxBound], render x == t] of + [x] -> pure x + _ -> fail ("unknown " <> T.unpack what <> " '" <> T.unpack t <> "'") + +thresholdsToJSON :: Thresholds -> Value +thresholdsToJSON t = object ["blockAt" .= (t ^. #blockAt), "passAt" .= (t ^. #passAt)] + +parseThresholds :: Value -> Parser Thresholds +parseThresholds = withObject "Thresholds" $ \o -> Thresholds <$> o .: "blockAt" <*> o .: "passAt" + +definitionToJSON :: JudgementDefinition -> Value +definitionToJSON d = + object + [ "name" .= (d ^. #name), + "version" .= (d ^. #version), + "description" .= (d ^. #description), + "instructions" .= (d ^. #instructions), + "evidence" + .= object + [ "scopes" .= map renderScopeKind (d ^. #evidence . #scopes), + "include" .= (d ^. #evidence . #include), + "exclude" .= (d ^. #evidence . #exclude) + ], + "limits" + .= object + [ "maxFileBytes" .= (d ^. #limits . #maxFileBytes), + "maxChunkBytes" .= (d ^. #limits . #maxChunkBytes), + "maxChunks" .= (d ^. #limits . #maxChunks), + "maxAttempts" .= (d ^. #limits . #maxAttempts), + "timeoutSeconds" .= (d ^. #limits . #timeoutSeconds), + "maxFindings" .= (d ^. #limits . #maxFindings) + ], + "deterministicChecks" .= map renderDeterministicCheck (d ^. #deterministicChecks), + "checks" .= map checkToJSON (toList (d ^. #checks)) + ] + where + checkToJSON c = + object + [ "name" .= (c ^. #name), + "question" .= (c ^. #question), + "concernWhen" .= renderAnswer (c ^. #concernWhen), + "yesMeans" .= (c ^. #yesMeans), + "noMeans" .= (c ^. #noMeans), + "categories" + .= [ object ["name" .= (cat ^. #name), "severity" .= renderSeverity (cat ^. #severity), "description" .= (cat ^. #description)] + | cat <- c ^. #categories + ], + "enforcement" .= renderEnforcement (c ^. #enforcement), + "blockingSeverity" .= renderSeverity (c ^. #blockingSeverity), + "review" .= thresholdsToJSON (c ^. #review), + "gate" .= thresholdsToJSON (c ^. #gate), + "useGate" .= (c ^. #useGate) + ] + +-- | Decode and structurally validate a definition snapshot. +parseDefinition :: Value -> Parser JudgementDefinition +parseDefinition = withObject "JudgementDefinition" $ \o -> do + evidence <- o .: "evidence" >>= withObject "EvidenceDeclaration" (\e -> EvidenceDeclaration <$> (mapM (enumText renderScopeKind "evidence scope") =<< e .: "scopes") <*> e .: "include" <*> e .: "exclude") + limits <- + o .: "limits" + >>= withObject + "CoverageLimits" + ( \l -> + CoverageLimits + <$> l .: "maxFileBytes" + <*> l .: "maxChunkBytes" + <*> l .: "maxChunks" + <*> l .: "maxAttempts" + <*> l .: "timeoutSeconds" + <*> l .: "maxFindings" + ) + rawChecks <- o .: "checks" + checks <- maybe (fail "a judgement needs at least one check") pure . NE.nonEmpty =<< mapM parseCheck rawChecks + d <- + JudgementDefinition + <$> o .: "name" + <*> o .: "version" + <*> o .: "description" + <*> o .: "instructions" + <*> pure evidence + <*> pure limits + <*> (mapM (enumText renderDeterministicCheck "deterministic check") =<< o .: "deterministicChecks") + <*> pure checks + either (fail . T.unpack . (^. #message)) (const (pure d)) (validateDefinition d) + where + parseCheck = withObject "JudgementCheck" $ \c -> + JudgementCheck + <$> c .: "name" + <*> c .: "question" + <*> (enumText renderAnswer "answer" =<< c .: "concernWhen") + <*> c .: "yesMeans" + <*> c .: "noMeans" + <*> (mapM parseCategory =<< c .: "categories") + <*> (enumText renderEnforcement "enforcement" =<< c .: "enforcement") + <*> (enumText renderSeverity "severity" =<< c .: "blockingSeverity") + <*> (parseThresholds =<< c .: "review") + <*> (parseThresholds =<< c .: "gate") + <*> c .: "useGate" + parseCategory = withObject "FindingCategory" $ \cat -> + FindingCategory <$> cat .: "name" <*> (enumText renderSeverity "severity" =<< cat .: "severity") <*> cat .: "description" + +policyToJSON :: JudgementPolicy -> Value +policyToJSON p = + object + [ "dataPolicy" .= renderDataPolicy (p ^. #dataPolicy), + "gatePermitted" .= (p ^. #gatePermitted), + "checks" .= Map.map checkPolicyToJSON (p ^. #checks) + ] + where + checkPolicyToJSON c = + object + [ "enforcement" .= renderEnforcement (c ^. #enforcement), + "blockingSeverity" .= renderSeverity (c ^. #blockingSeverity), + "review" .= thresholdsToJSON (c ^. #review), + "gate" .= thresholdsToJSON (c ^. #gate), + "useGate" .= (c ^. #useGate) + ] + +-- | Decode a policy and check it against the definition it governs: every +-- check has exactly one policy entry and every threshold pair is valid. +parsePolicy :: JudgementDefinition -> Value -> Parser JudgementPolicy +parsePolicy def = withObject "JudgementPolicy" $ \o -> do + raw <- o .: "checks" :: Parser (Map Text Value) + checks <- Map.traverseWithKey (const parseCheckPolicy) raw + let declared = map (^. #name) (toList (def ^. #checks)) + unless (Map.keys checks == sortedUnique declared) $ + fail ("judgement '" <> T.unpack (def ^. #name) <> "' policy must name exactly its checks: " <> T.unpack (T.intercalate ", " declared)) + forM_ (Map.toList checks) $ \(name, c) -> do + either (fail . T.unpack . (^. #message)) pure (validateThresholds ("check '" <> name <> "' review") (c ^. #review)) + either (fail . T.unpack . (^. #message)) pure (validateThresholds ("check '" <> name <> "' gate") (c ^. #gate)) + JudgementPolicy + <$> (enumText renderDataPolicy "data policy" =<< o .: "dataPolicy") + <*> o .: "gatePermitted" + <*> pure checks + where + sortedUnique = Map.keys . Map.fromList . map (,()) + parseCheckPolicy = withObject "CheckPolicy" $ \c -> + CheckPolicy + <$> (enumText renderEnforcement "enforcement" =<< c .: "enforcement") + <*> (enumText renderSeverity "severity" =<< c .: "blockingSeverity") + <*> (parseThresholds =<< c .: "review") + <*> (parseThresholds =<< c .: "gate") + <*> c .: "useGate" diff --git a/src/Seihou/Manifest/Types.hs b/src/Seihou/Manifest/Types.hs --- a/src/Seihou/Manifest/Types.hs +++ b/src/Seihou/Manifest/Types.hs @@ -41,6 +41,7 @@ import Seihou.Core.Types import Seihou.Manifest.Hash (baselineRefFromText) import Seihou.Manifest.JSON (decodeManifestValue) +import Seihou.Manifest.Judgement (definitionDigest, definitionToJSON, parseDefinition, parsePolicy, policyToJSON) import Seihou.Prelude hiding ((.=)) import System.FilePath (takeFileName) @@ -86,8 +87,10 @@ -- Schema 14 records conditional removal policies and single-root closure retirement. -- Missing removal conditions remain unconditional; 13 -> 14 adds null instance -- policies where accepted typed evidence is unknown. +-- Schema 15 records active judgements: a definition snapshot, its digest and +-- the project policy. 14 -> 15 adds an empty judgement list. currentManifestVersion :: ManifestSchemaVersion -currentManifestVersion = ManifestSchemaVersion 14 +currentManifestVersion = ManifestSchemaVersion 15 -- | The oldest schema the ordinary decoder reads. Anything older records -- machine-specific absolute paths and must go through the explicit @@ -107,6 +110,7 @@ minimumManifestVersion SeedOwnerClaims = ManifestSchemaVersion 11 minimumManifestVersion CheckoutLocalOutputs = ManifestSchemaVersion 9 minimumManifestVersion CheckoutLocalCommands = ManifestSchemaVersion 10 +minimumManifestVersion JudgementState = ManifestSchemaVersion 15 -- | Whether a manifest's schema can express everything a capability needs. -- A decoded schema-6 manifest answers 'False' for @@ -130,7 +134,8 @@ blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, - blueprintMigrations = [] + blueprintMigrations = [], + judgements = [] } -- | Record an applied-blueprint provenance on a manifest, replacing any @@ -150,7 +155,8 @@ blueprint = Just ab, seeds = m ^. #seeds, checkoutOutputs = m ^. #checkoutOutputs, - blueprintMigrations = m ^. #blueprintMigrations + blueprintMigrations = m ^. #blueprintMigrations, + judgements = m ^. #judgements } -- | Insert or replace one exact blueprint migration receipt. Replacement is @@ -174,7 +180,8 @@ blueprint = manifest ^. #blueprint, seeds = manifest ^. #seeds, checkoutOutputs = manifest ^. #checkoutOutputs, - blueprintMigrations = upsert (manifest ^. #blueprintMigrations) + blueprintMigrations = upsert (manifest ^. #blueprintMigrations), + judgements = manifest ^. #judgements } where sameEdge existing = @@ -235,6 +242,7 @@ ] ++ ["checkoutOutputs" .= Map.map checkoutToJSON (m ^. #checkoutOutputs) | m ^. #version >= ManifestSchemaVersion 9] ++ ["seeds" .= Map.map (seedToJSON (m ^. #version)) (m ^. #seeds) | m ^. #version >= ManifestSchemaVersion 8] + ++ ["judgements" .= map activeJudgementToJSON (m ^. #judgements) | manifestSupports JudgementState m] ++ maybe [] (\r -> ["recipe" .= r]) (m ^. #recipe) ++ maybe [] (\b -> ["blueprint" .= b]) (m ^. #blueprint) @@ -257,6 +265,9 @@ <*> o Aeson..:? "recipe" <*> o Aeson..:? "blueprint" <*> o Aeson..:? "blueprintMigrations" Aeson..!= [] + <*> (if v >= minimumManifestVersion JudgementState then mapM parseActiveJudgement =<< o .: "judgements" else pure []) + let judgementNames = map (^. #definition . #name) (manifest ^. #judgements) + unless (Set.size (Set.fromList judgementNames) == length judgementNames) $ fail "manifest records the same judgement name more than once" unless (manifestSupports ConditionalRemovalPolicies manifest || not (hasConditionalRemoval manifest || hasRemovalPolicy manifest)) $ fail "conditional removal policies require manifest schema 14" case validateManifestInvariants manifest of Left err -> fail (T.unpack (renderManifestInvariantError err)) @@ -937,6 +948,7 @@ <> ["removal commands cannot declare checkout setup" | applied <- manifest ^. #modules, removal <- maybe [] pure (applied ^. #removal), any ((== CheckoutCommandLifecycle) . (^. #lifecycle)) (removal ^. #commands)] <> ["checkout commands require manifest schema 10" | manifest ^. #version < ManifestSchemaVersion 10, any (not . null . (^. #checkoutCommands)) (manifest ^. #applications)] <> ["checkout outputs require manifest schema 9" | manifest ^. #version < ManifestSchemaVersion 9, not (Map.null (manifest ^. #checkoutOutputs))] + <> ["judgements require manifest schema 15" | not (manifestSupports JudgementState manifest), not (null (manifest ^. #judgements))] <> ["seed receipts require manifest schema 8" | manifest ^. #version < ManifestSchemaVersion 8, not (Map.null (manifest ^. #seeds))] checkoutToJSON :: CheckoutOutputRecord -> Aeson.Value @@ -989,3 +1001,49 @@ unless (command ^. #occurrence >= 0 && not (T.null (T.strip (command ^. #command)))) (fail "invalid checkout command occurrence or empty shell text") forM_ (command ^. #workDir) $ \path -> unless (path == ".") $ either (fail . T.unpack) pure (validateCanonicalProjectPath (T.pack path)) + +activeJudgementToJSON :: ActiveJudgement -> Aeson.Value +activeJudgementToJSON j = + Aeson.object + [ "source" .= case j ^. #source of + BundledJudgement -> Aeson.object ["kind" .= ("bundled" :: Text)] + ArtifactJudgement origin -> Aeson.object ["kind" .= ("artifact" :: Text), "origin" .= origin], + "definition" .= definitionToJSON (j ^. #definition), + "digest" .= (j ^. #digest . #unSHA256), + "policy" .= policyToJSON (j ^. #policy), + "owners" .= map ownerToJSON (j ^. #owners) + ] + where + ownerToJSON = \case + DirectAdoption -> Aeson.object ["kind" .= ("direct" :: Text)] + ApplicationOwner a -> Aeson.object ["kind" .= ("application" :: Text), "applicationId" .= (a ^. #unApplicationId)] + +-- | A recorded snapshot whose digest no longer matches its definition was +-- edited by hand; refuse it rather than check against unreviewed policy. +parseActiveJudgement :: Aeson.Value -> Aeson.Parser ActiveJudgement +parseActiveJudgement = Aeson.withObject "ActiveJudgement" $ \o -> do + source <- + o .: "source" + >>= Aeson.withObject + "JudgementSource" + ( \s -> + (s .: "kind" :: Aeson.Parser Text) >>= \case + "bundled" -> pure BundledJudgement + "artifact" -> ArtifactJudgement <$> s .: "origin" + other -> fail ("unknown judgement source kind: " <> T.unpack other) + ) + definition <- parseDefinition =<< o .: "definition" + recorded <- o .: "digest" + let actual = definitionDigest definition + unless (T.toLower recorded == actual ^. #unSHA256) $ + fail ("judgement '" <> T.unpack (definition ^. #name) <> "' does not match its recorded digest; re-apply it with 'seihou run " <> T.unpack (definition ^. #name) <> "'") + policy <- parsePolicy definition =<< o .: "policy" + owners <- mapM parseOwner =<< o .: "owners" + when (null owners) $ fail ("judgement '" <> T.unpack (definition ^. #name) <> "' has no owners; remove it from the manifest or re-apply it") + pure (ActiveJudgement source definition actual policy owners) + where + parseOwner = Aeson.withObject "JudgementOwner" $ \w -> + (w .: "kind" :: Aeson.Parser Text) >>= \case + "direct" -> pure DirectAdoption + "application" -> ApplicationOwner . ApplicationId <$> w .: "applicationId" + other -> fail ("unknown judgement owner kind: " <> T.unpack other) diff --git a/src/Seihou/Manifest/Upgrade.hs b/src/Seihou/Manifest/Upgrade.hs --- a/src/Seihou/Manifest/Upgrade.hs +++ b/src/Seihou/Manifest/Upgrade.hs @@ -64,6 +64,7 @@ | AddUnknownRecipeChain | MakeSeedOwnershipExplicit | AddEmptyCheckoutCommands + | AddEmptyJudgements deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) -- | Whether a step may be staged automatically. @@ -128,7 +129,8 @@ step 10 MakeSeedOwnershipExplicit "explicit seed instance ownership", step 11 AddUnknownRecipeInputs "recipe inputs", step 12 AddUnknownRecipeChain "recipe inheritance provenance", - step 13 IntroduceConditionalRemoval "conditional removal policies and recorded root retirement" + step 13 IntroduceConditionalRemoval "conditional removal policies and recorded root retirement", + step 14 AddEmptyJudgements "active judgements" ] where step from stepAction = @@ -145,6 +147,7 @@ upgradeStepKind AddEmptyCheckoutOutputs = LosslessUpgrade upgradeStepKind AddEmptyCheckoutCommands = LosslessUpgrade upgradeStepKind MakeSeedOwnershipExplicit = LosslessUpgrade +upgradeStepKind AddEmptyJudgements = LosslessUpgrade -- | The contiguous steps from @source@ to @target@. Planning from a version -- to itself is an empty path. @@ -219,6 +222,12 @@ Aeson.Object fields -> Right (Aeson.Object (KeyMap.insert "applications" (addInputs (fromMaybe (Aeson.Array mempty) (KeyMap.lookup "applications" fields))) fields)) _ -> Right document StampVersion -> Right document + AddEmptyJudgements -> case document of + Aeson.Object fields -> case KeyMap.lookup "judgements" fields of + Nothing -> Right (Aeson.Object (KeyMap.insert "judgements" (Aeson.toJSON ([] :: [Aeson.Value])) fields)) + Just (Aeson.Array xs) | null xs -> Right document + _ -> Left (MalformedDocument actual "schema 14 cannot contain judgements") + _ -> Left (MalformedDocument actual "manifest must be an object") MakeSeedOwnershipExplicit -> first (MalformedDocument actual) (makeSeedOwnershipExplicit document) AddEmptyCheckoutCommands -> case document of Aeson.Object fields -> do diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -18,9 +18,12 @@ import Seihou.Core.EntailmentSpec qualified as EntailmentSpec import Seihou.Core.ExprSpec qualified as ExprSpec import Seihou.Core.InstallSpec qualified as InstallSpec +import Seihou.Core.JudgementArtifactSpec qualified as JudgementArtifactSpec +import Seihou.Core.JudgementSpec qualified as JudgementSpec import Seihou.Core.ListSpec qualified as ListSpec import Seihou.Core.MigrationSpec qualified as MigrationSpec import Seihou.Core.ModuleSpec qualified as ModuleSpec +import Seihou.Core.PathSpec qualified as PathSpec import Seihou.Core.RecipeSpec qualified as RecipeSpec import Seihou.Core.RegistryEmitSpec qualified as RegistryEmitSpec import Seihou.Core.RegistrySpec qualified as RegistrySpec @@ -92,9 +95,12 @@ entailmentTests <- EntailmentSpec.tests exprTests <- ExprSpec.tests installTests <- InstallSpec.tests + judgementTests <- JudgementSpec.tests + judgementArtifactTests <- JudgementArtifactSpec.tests listTests <- ListSpec.tests migrationTests <- MigrationSpec.tests moduleTests <- ModuleSpec.tests + pathTests <- PathSpec.tests recipeTests <- RecipeSpec.tests registryTests <- RegistrySpec.tests registryEmitTests <- RegistryEmitSpec.tests @@ -144,4 +150,4 @@ confirmTests <- ConfirmSpec.tests seedTransactionTests <- SeedTransaction.tests seedEngineTests <- SeedEngine.tests - defaultMain (testGroup "seihou-core" [seedTransactionTests, seedEngineTests, graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactIdentityTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, checkoutEngineTests, checkoutTests, seedTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, manifestUpgradeTests, promptTests, confirmTests]) + defaultMain (testGroup "seihou-core" [seedTransactionTests, seedEngineTests, graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactIdentityTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, judgementTests, judgementArtifactTests, listTests, migrationTests, moduleTests, pathTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, checkoutEngineTests, checkoutTests, seedTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, manifestUpgradeTests, promptTests, confirmTests]) diff --git a/test/Seihou/Core/ArtifactIdentitySpec.hs b/test/Seihou/Core/ArtifactIdentitySpec.hs --- a/test/Seihou/Core/ArtifactIdentitySpec.hs +++ b/test/Seihou/Core/ArtifactIdentitySpec.hs @@ -3,7 +3,8 @@ import Control.Monad (forM_) import Data.Text (Text) import Data.Text qualified as T -import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl) +import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl, repositoryOriginKey, sameArtifactIdentity, sameRepositoryOrigin) +import Seihou.Core.Types (ArtifactOrigin (..)) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec) @@ -49,14 +50,193 @@ isMachineLocalOriginUrl url `shouldBe` False describe "normalizeOriginUrl" $ do - it "recognizes public GitHub SSH and HTTPS transports as the same repository" $ - map - normalizeOriginUrl - [ "git@github.com:shinzui/seihou-modules.git", - "ssh://git@github.com/shinzui/seihou-modules.git/", - "https://github.com/shinzui/seihou-modules/" + it "keeps the cosmetic .git and trailing-slash spellings together" $ + map normalizeOriginUrl ["https://host/repo", "https://host/repo.git", "https://host/repo/", " https://host/repo.git/ "] + `shouldBe` replicate 4 "https://host/repo" + it "does not equate transports, so connection-specific keys stay specific" $ + normalizeOriginUrl "git@github.com:shinzui/seihou-modules.git" `shouldNotBe` normalizeOriginUrl "https://github.com/shinzui/seihou-modules" + it "does not erase a separate .git path component" $ + normalizeOriginUrl "https://host/owner/repo/.git" `shouldNotBe` normalizeOriginUrl "https://host/owner/repo" + + describe "sameRepositoryOrigin" $ do + forM_ equivalenceClasses $ \(label, members) -> + describe label $ + forM_ [(a, b) | a <- members, b <- members] $ \(a, b) -> + it (T.unpack a <> " ~ " <> T.unpack b) $ sameRepositoryOrigin a b `shouldBe` True + + forM_ distinctPairs $ \(a, b) -> + it (T.unpack a <> " differs from " <> T.unpack b) $ do + sameRepositoryOrigin a b `shouldBe` False + sameRepositoryOrigin b a `shouldBe` False + + it "keeps every class apart from every other class" $ + and + [ not (sameRepositoryOrigin a b) + | (i, (_, left)) <- indexed, + (j, (_, right)) <- indexed, + i /= j, + a <- left, + b <- right ] - `shouldBe` replicate 3 "https://github.com/shinzui/seihou-modules" - it "keeps different repositories and hosts distinct" $ do - normalizeOriginUrl "git@github.com:other/seihou-modules.git" `shouldNotBe` normalizeOriginUrl "https://github.com/shinzui/seihou-modules" - normalizeOriginUrl "git@git.example:shinzui/seihou-modules.git" `shouldNotBe` normalizeOriginUrl "https://git.example/shinzui/seihou-modules" + `shouldBe` True + + it "is reflexive, symmetric and transitive over every sample" $ do + let samples = concatMap snd equivalenceClasses <> concatMap (\(a, b) -> [a, b]) distinctPairs + all (\a -> sameRepositoryOrigin a a) samples `shouldBe` True + and [sameRepositoryOrigin a b == sameRepositoryOrigin b a | a <- samples, b <- samples] `shouldBe` True + and + [ sameRepositoryOrigin a c + | a <- samples, + b <- samples, + sameRepositoryOrigin a b, + c <- samples, + sameRepositoryOrigin b c + ] + `shouldBe` True + + it "never lets malformed or hostile input become the recognised GitHub repository" $ + forM_ (concatMap (\(a, b) -> [a, b]) distinctPairs) $ \candidate -> + if candidate `elem` reportedClass + then pure () + else repositoryOriginKey candidate `shouldNotBe` repositoryOriginKey reportedHttps + + describe "sameArtifactIdentity" $ do + it "treats the reported SSH and HTTPS records of one module as one artifact" $ + sameArtifactIdentity + (RemoteOrigin "git@github.com:shinzui/seihou-modules.git" "git-init" Nothing) + (RemoteOrigin reportedHttps "git-init" (Just "seihou-modules")) + `shouldBe` True + it "still requires the artifact name to agree" $ + sameArtifactIdentity + (RemoteOrigin "git@github.com:shinzui/seihou-modules.git" "git-init" Nothing) + (RemoteOrigin reportedHttps "haskell-base" Nothing) + `shouldBe` False + it "keeps project and local origins unchanged" $ do + sameArtifactIdentity (ProjectOrigin "./.seihou/modules/a/") (ProjectOrigin ".seihou/modules/a") `shouldBe` True + sameArtifactIdentity (LocalOrigin "a") (LocalOrigin "a") `shouldBe` True + sameArtifactIdentity (LocalOrigin "a") (RemoteOrigin "a" "a" Nothing) `shouldBe` False + where + indexed = zip [0 :: Int ..] equivalenceClasses + +reportedHttps :: Text +reportedHttps = "https://github.com/shinzui/seihou-modules.git" + +reportedClass :: [Text] +reportedClass = maybe [] id (lookup "public GitHub transports of one repository" equivalenceClasses) + +-- | Each list is one repository; every member must equal every other member +-- and no member of any other list. +equivalenceClasses :: [(String, [Text])] +equivalenceClasses = + [ ( "public GitHub transports of one repository", + [ "git@github.com:shinzui/seihou-modules.git", + reportedHttps, + "https://github.com/shinzui/seihou-modules", + "https://github.com/shinzui/seihou-modules/", + "https://github.com/shinzui/seihou-modules.git/", + " https://github.com/shinzui/seihou-modules ", + "HTTPS://GitHub.COM/shinzui/seihou-modules", + "https://github.com:443/shinzui/seihou-modules", + "https://token@github.com/shinzui/seihou-modules.git", + "ssh://git@github.com/shinzui/seihou-modules.git", + "ssh://git@github.com:22/shinzui/seihou-modules", + "ssh://git@ssh.github.com:443/shinzui/seihou-modules.git", + "git@GitHub.com:shinzui/seihou-modules/" + ] + ), + ( "a generic HTTPS repository with cosmetic spellings", + [ "https://git.example/team/repo", + "https://git.example/team/repo.git", + "https://GIT.example:443/team/repo/" + ] + ), + ( "a generic SSH URL with an explicit default port", + [ "ssh://alice@git.example/srv/repo.git", + "ssh://alice@git.example:22/srv/repo" + ] + ), + ( "a generic relative scp path", + ["alice@git.example:repo.git", "alice@GIT.EXAMPLE:repo/"] + ), + ( "a git-protocol URL with its default port", + ["git://git.example/repo.git", "git://git.example:9418/repo"] + ), + ( "a bracketed IPv6 authority", + ["ssh://git@[2001:db8::1]:2222/repo.git", "ssh://git@[2001:DB8::1]:2222/repo"] + ), + ( "an opaque local path", + ["/srv/repos/modules", "/srv/repos/modules.git/"] + ) + ] + +-- | Pairs that must never compare equal, in either direction. +distinctPairs :: [(Text, Text)] +distinctPairs = + [ ("git@github.com:other/seihou-modules.git", reportedHttps), + ("git@github.com:shinzui/other.git", reportedHttps), + ("https://github.com/Shinzui/seihou-modules", reportedHttps), + ("git@git.example:shinzui/seihou-modules.git", "https://git.example/shinzui/seihou-modules"), + ("http://github.com/shinzui/seihou-modules", reportedHttps), + ("git://github.com/shinzui/seihou-modules.git", reportedHttps), + ("https://github.com.evil.example/shinzui/seihou-modules.git", reportedHttps), + ("https://github.com@evil.example/shinzui/seihou-modules.git", reportedHttps), + ("https://www.github.com/shinzui/seihou-modules", reportedHttps), + ("https://github.com:8443/shinzui/seihou-modules", reportedHttps), + ("https://github.com:/shinzui/seihou-modules", reportedHttps), + ("https://github.com:0/shinzui/seihou-modules", reportedHttps), + ("https://github.com:65536/shinzui/seihou-modules", reportedHttps), + ("https://github.com:4x3/shinzui/seihou-modules", reportedHttps), + ("ssh://github.com/shinzui/seihou-modules.git", reportedHttps), + ("ssh://alice@github.com/shinzui/seihou-modules.git", reportedHttps), + ("ssh://git@github.com:2222/shinzui/seihou-modules.git", reportedHttps), + ("ssh://git@ssh.github.com/shinzui/seihou-modules.git", reportedHttps), + ("ssh://git@ssh.github.com:22/shinzui/seihou-modules.git", reportedHttps), + ("alice@github.com:shinzui/seihou-modules.git", reportedHttps), + ("github.com:shinzui/seihou-modules.git", reportedHttps), + ("git@github.com:/shinzui/seihou-modules.git", reportedHttps), + ("git@github.com:~/shinzui/seihou-modules.git", reportedHttps), + ("https://github.com/shinzui/seihou-modules/.git", reportedHttps), + ("https://github.com/shinzui/seihou-modules/extra", reportedHttps), + ("https://github.com//shinzui/seihou-modules", reportedHttps), + ("https://github.com/shinzui//seihou-modules", reportedHttps), + ("https://github.com/shinzui/seihou-modules?", reportedHttps), + ("https://github.com/shinzui/seihou-modules#", reportedHttps), + ("https://github.com/shinzui/seihou-modules?ref=main", reportedHttps), + ("https://github.com/shinzui/seihou%2Dmodules", reportedHttps), + ("https://github.com/shinzui/seihou modules", reportedHttps), + ("https://github.com/shinzui/..", "https://github.com/shinzui/."), + ("https://github.com/owner/.git", "https://github.com/owner"), + ("https:///shinzui/seihou-modules", reportedHttps), + ("https://github.com", reportedHttps), + ("seihou-modules", reportedHttps), + ("ftp://github.com/shinzui/seihou-modules", reportedHttps), + ("file:///srv/shinzui/seihou-modules", reportedHttps), + ("/srv/shinzui/seihou-modules", "ssh://git@github.com/srv/shinzui/seihou-modules"), + ("C:/src/seihou-modules", "c:/src/seihou-modules.git"), + ("https://example.com/repo?ref=topic.git", "https://example.com/repo?ref=topic"), + ("https://example.com/repo?", "https://example.com/repo"), + ("https://example.com/repo#", "https://example.com/repo"), + ("https://example.com/Repo", "https://example.com/repo"), + ("https://example.com/repo/.git", "https://example.com/repo"), + ("https://example.com/a%2Fb", "https://example.com/a/b"), + ("https://example.com/a/./b", "https://example.com/a/b"), + ("https://example.com/a//b", "https://example.com/a/b"), + ("https://example.com:8443/repo", "https://example.com/repo"), + ("https://alice@example.com/repo", "https://example.com/repo"), + ("ssh://alice@git.example/repo", "ssh://bob@git.example/repo"), + ("ssh://alice@git.example/repo", "ssh://git.example/repo"), + ("ssh://alice@git.example:2222/repo", "ssh://alice@git.example:2223/repo"), + ("ssh://alice@git.example/repo", "https://git.example/repo"), + ("http://example.com/repo", "https://example.com/repo"), + ("http://example.com:443/repo", "https://example.com/repo"), + ("alice@git.example:repo", "ssh://alice@git.example/repo"), + ("alice@git.example:/srv/repo", "ssh://alice@git.example/srv/repo"), + ("alice@git.example:/srv/repo", "alice@git.example:srv/repo"), + ("alice@git.example:repo", "bob@git.example:repo"), + ("alice@git.example:repo", "git.example:repo"), + ("alice@git.example:repo", "https://git.example/repo"), + ("ssh://git@[2001:db8::1]/repo", "ssh://git@[2001:db8::2]/repo"), + ("ssh://git@[2001:db8::1/repo", "ssh://git@[2001:db8::1]/repo"), + ("svn+ssh://git.example/repo", "ssh://git.example/repo"), + ("unknown://github.com/shinzui/seihou-modules", reportedHttps) + ] diff --git a/test/Seihou/Core/JudgementArtifactSpec.hs b/test/Seihou/Core/JudgementArtifactSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/JudgementArtifactSpec.hs @@ -0,0 +1,194 @@ +-- | Judgements as ordinary artifacts: registry entries, registry validation +-- and synchronization, discovery, enumeration, and the ambiguity rule for a +-- @judgement.dhall@ that shares its directory with another definition file. +module Seihou.Core.JudgementArtifactSpec (tests) where + +import Data.Generics.Labels () +import Data.List (isInfixOf) +import Data.Text qualified as T +import Seihou.Core.Module (DiscoveredRunnable (..), RunnableKind (..), discoverAllRunnables, discoverRunnable) +import Seihou.Core.Registry +import Seihou.Core.Types (ModuleLoadError (..), ModuleName (..), Runnable (..)) +import Seihou.Dhall.Eval (evalRegistryFromFile) +import Seihou.Prelude +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.JudgementArtifact" spec + +entry :: Text -> FilePath -> RegistryEntry +entry n p = RegistryEntry (ModuleName n) Nothing p Nothing [] + +registry :: [RegistryEntry] -> [RegistryEntry] -> Registry +registry mods judgements = + Registry + { repoName = "fixture", + repoDescription = Nothing, + modules = mods, + recipes = [], + blueprints = [], + prompts = [], + judgements = judgements + } + +-- | A minimal judgement definition importing the local schema. +writeJudgement :: FilePath -> Text -> Text -> IO () +writeJudgement dir name version = do + cwd <- getCurrentDirectory + createDirectoryIfMissing True dir + writeFile (dir "judgement.dhall") $ + "let S = " + <> cwd + <> "/../schema/package.dhall in S.Judgement::{ name = \"" + <> T.unpack name + <> "\", version = Some \"" + <> T.unpack version + <> "\", description = Some \"Guards data\", checks = [ S.Check::{ name = \"c\", question = \"q?\" } ] }" + +writeModule :: FilePath -> Text -> IO () +writeModule dir name = do + cwd <- getCurrentDirectory + createDirectoryIfMissing True dir + writeFile (dir "module.dhall") ("let S = " <> cwd <> "/../schema/package.dhall in S.Module::{ name = \"" <> T.unpack name <> "\" }") + +spec :: Spec +spec = do + describe "registry judgements" $ do + it "decodes a registry with a judgement entry" $ + withSystemTempDirectory "judgement-registry" $ \tmp -> do + writeFile (tmp "seihou-registry.dhall") $ + "{ repoName = \"r\", repoDescription = None Text\n\ + \, modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \, judgements = [ { name = \"guard\", version = Some \"0.1.0\", path = \"judgements/guard\", description = Some \"Guards data\", tags = [ \"review\" ] } ]\n\ + \}" + result <- evalRegistryFromFile (tmp "seihou-registry.dhall") + case result of + Left err -> expectationFailure (show err) + Right reg -> do + reg ^. #judgements `shouldBe` [RegistryEntry (ModuleName "guard") (Just "0.1.0") "judgements/guard" (Just "Guards data") ["review"]] + reg ^. #prompts `shouldBe` [] + + it "decodes a legacy registry without a judgements field as an empty list" $ + withSystemTempDirectory "judgement-registry-legacy" $ \tmp -> do + writeFile (tmp "seihou-registry.dhall") $ + "{ repoName = \"r\", repoDescription = None Text\n\ + \, modules = [ { name = \"m\", version = None Text, path = \"m\", description = None Text, tags = [] : List Text } ]\n\ + \, recipes = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \, blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \, prompts = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \}" + result <- evalRegistryFromFile (tmp "seihou-registry.dhall") + fmap (^. #judgements) result `shouldBe` Right [] + + it "round-trips judgement entries through renderRegistryDhall" $ + withSystemTempDirectory "judgement-registry-emit" $ \tmp -> do + let reg = registry [entry "m" "m"] [RegistryEntry (ModuleName "guard") (Just "0.1.0") "guard" (Just "Guards") ["a"]] + writeFile (tmp "seihou-registry.dhall") (T.unpack (renderRegistryDhall reg)) + evalRegistryFromFile (tmp "seihou-registry.dhall") `shouldReturn` Right reg + + it "accepts a well-formed judgement entry" $ + withSystemTempDirectory "judgement-validate-ok" $ \tmp -> do + writeJudgement (tmp "guard") "guard" "0.1.0" + validateRegistry tmp (registry [] [entry "guard" "guard"]) `shouldReturn` [] + + it "reports a judgement entry whose judgement.dhall is missing" $ + withSystemTempDirectory "judgement-validate-missing" $ \tmp -> do + errs <- validateRegistry tmp (registry [] [entry "ghost" "ghost"]) + errs `shouldBe` ["registry judgement entry 'ghost' points to missing judgement.dhall at ghost"] + + it "reports an invalid name and an unsafe path" $ + withSystemTempDirectory "judgement-validate-unsafe" $ \tmp -> do + errs <- validateRegistry tmp (registry [] [entry "Bad_Name" "../escape"]) + errs `shouldSatisfy` elem "registry judgement name must match [a-z][a-z0-9-]*, got: Bad_Name" + errs `shouldSatisfy` elem "registry judgement path must not contain '..': ../escape" + + it "reports a judgement whose name collides with a module" $ + withSystemTempDirectory "judgement-validate-collision" $ \tmp -> do + writeModule (tmp "modules" "shared") "shared" + writeJudgement (tmp "judgements" "shared") "shared" "0.1.0" + errs <- validateRegistry tmp (registry [entry "shared" "modules/shared"] [entry "shared" "judgements/shared"]) + errs `shouldBe` ["name collision: 'shared' appears as both a module and a judgement"] + + it "reports an entry directory where judgement.dhall sits next to module.dhall" $ + withSystemTempDirectory "judgement-validate-ambiguous" $ \tmp -> do + writeModule (tmp "mixed") "mixed" + writeJudgement (tmp "mixed") "mixed" "0.1.0" + errs <- validateRegistry tmp (registry [] [entry "mixed" "mixed"]) + errs `shouldSatisfy` any (T.isInfixOf "ambiguous artifact 'mixed'") + errs `shouldSatisfy` any (T.isInfixOf "module.dhall, judgement.dhall") + + it "classifies judgement version drift and counts judgements" $ + withSystemTempDirectory "judgement-validate-full" $ \tmp -> do + writeJudgement (tmp "guard") "guard" "0.2.0" + let reg = registry [] [RegistryEntry (ModuleName "guard") (Just "0.1.0") "guard" Nothing []] + lookups = [(JudgementEntry, ModuleName "guard", Just "0.2.0")] + report = computeRegistrySync reg lookups + map (^. #status) (report ^. #diffs) `shouldBe` [SyncStale "0.2.0"] + map (^. #kind) (report ^. #diffs) `shouldBe` [JudgementEntry] + fmap (^. #version) (report ^. #updated . #judgements) `shouldBe` [Just "0.2.0"] + full <- validateRegistryFull tmp reg lookups + full ^. #judgementCount `shouldBe` 1 + map formatValidationIssue (full ^. #issues) + `shouldBe` ["judgements.guard: registry version 0.1.0 does not match judgement.dhall version 0.2.0"] + + it "recognises a single-judgement repository root" $ + withSystemTempDirectory "judgement-single-root" $ \tmp -> do + writeJudgement tmp "guard" "0.1.0" + contents <- discoverRepoContents evalRegistryFromFile tmp + case contents of + SingleJudgement root -> root `shouldBe` tmp + other -> expectationFailure ("expected SingleJudgement, got " <> show other) + + describe "judgement discovery" $ do + it "discovers a judgement directory by name" $ + withSystemTempDirectory "judgement-discover" $ \tmp -> do + writeJudgement (tmp "guard") "guard" "0.1.0" + result <- discoverRunnable [tmp] (ModuleName "guard") + case result of + Right (RunnableJudgement def dir) -> do + def ^. #name `shouldBe` "guard" + dir `shouldBe` tmp "guard" + Right _ -> expectationFailure "expected a judgement" + Left err -> expectationFailure (show err) + + it "rejects a judgement co-located with a module as AmbiguousArtifact" $ + withSystemTempDirectory "judgement-ambiguous" $ \tmp -> do + writeModule (tmp "mixed") "mixed" + writeJudgement (tmp "mixed") "mixed" "0.1.0" + result <- discoverRunnable [tmp] (ModuleName "mixed") + case result of + Left (AmbiguousArtifact name dir files) -> do + name `shouldBe` ModuleName "mixed" + dir `shouldBe` tmp "mixed" + files `shouldBe` ["module.dhall", "judgement.dhall"] + Left err -> expectationFailure ("expected AmbiguousArtifact, got " <> show err) + Right _ -> expectationFailure "expected AmbiguousArtifact, got a runnable" + + it "keeps module precedence for combinations without a judgement" $ + withSystemTempDirectory "judgement-no-ambiguity" $ \tmp -> do + writeModule (tmp "plain") "plain" + writeFile (tmp "plain" "prompt.dhall") "this is never read" + result <- discoverRunnable [tmp] (ModuleName "plain") + case result of + Right (RunnableModule _ _) -> pure () + Right _ -> expectationFailure "expected the module" + Left err -> expectationFailure (show err) + + it "enumerates judgements with their kind, and an ambiguous directory as an error" $ + withSystemTempDirectory "judgement-enumerate" $ \tmp -> do + writeJudgement (tmp "guard") "guard" "0.1.0" + writeModule (tmp "mixed") "mixed" + writeJudgement (tmp "mixed") "mixed" "0.1.0" + found <- discoverAllRunnables [tmp] + let rows = [(r ^. #name, r ^. #kind, r ^. #isError, r ^. #description) | r <- found] + rows `shouldSatisfy` elem ("guard", KindJudgement, False, Just "Guards data") + case [r | r <- found, r ^. #name == "mixed"] of + [r] -> do + r ^. #kind `shouldBe` KindJudgement + r ^. #isError `shouldBe` True + fmap T.unpack (r ^. #error) `shouldSatisfy` maybe False ("judgement.dhall" `isInfixOf`) + other -> expectationFailure ("expected one row for mixed, got " <> show (length other)) diff --git a/test/Seihou/Core/JudgementSpec.hs b/test/Seihou/Core/JudgementSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/JudgementSpec.hs @@ -0,0 +1,332 @@ +module Seihou.Core.JudgementSpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.Either (isLeft, isRight) +import Data.Generics.Labels () +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time (UTCTime (..), fromGregorian) +import Seihou.Core.Judgement +import Seihou.Core.JudgementState (AdoptionChange (..), adoptWithOwner, policyWeakenings, pruneJudgementOwners, retireOwner) +import Seihou.Core.Types (ActiveJudgement (..), ApplicationId (..), JudgementOwner (..), JudgementSource (..), Manifest, ManifestSchemaVersion (..)) +import Seihou.Dhall.Eval (evalJudgementFromFile, evalJudgementRefsFromFile) +import Seihou.Manifest.Judgement (definitionDigest) +import Seihou.Manifest.Types (emptyManifest, manifestFromJSON, manifestToJSON) +import Seihou.Prelude +import System.Directory (getCurrentDirectory) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +category :: Text -> Severity -> FindingCategory +category n s = FindingCategory n s Nothing + +mkCheck :: Text -> Answer -> Thresholds -> JudgementCheck +mkCheck n concern t = + JudgementCheck + { name = n, + question = "Is the concern present?", + concernWhen = concern, + yesMeans = Nothing, + noMeans = Nothing, + categories = [category "credential" Critical, category "style" Low], + enforcement = Enforced, + blockingSeverity = High, + review = t, + gate = Thresholds 0.6 0.05, + useGate = True + } + +strictBand, lenientBand :: Thresholds +strictBand = Thresholds 0.5 0.1 +lenientBand = Thresholds 0.9 0.6 + +definition :: NonEmpty JudgementCheck -> JudgementDefinition +definition cs = + JudgementDefinition + { name = "demo", + version = Just "1.0.0", + description = Nothing, + instructions = "Review the change.", + evidence = defaultEvidenceDeclaration, + limits = defaultCoverageLimits, + deterministicChecks = [], + checks = cs + } + +complete :: Coverage +complete = Coverage ["a.txt"] [] [] + +reviewAt :: Double -> ReviewObservation +reviewAt p = ReviewObservation p [] False + +chunkWith :: Maybe GateObservation -> Maybe (Either Text ReviewObservation) -> ChunkObservation +chunkWith = ChunkObservation 0 + +policyOf :: JudgementCheck -> CheckPolicy +policyOf c = checkPolicyFor (defaultPolicy ApprovedRemote True (definition (c :| []))) c + +statusOf :: Bool -> JudgementCheck -> ChunkObservation -> CheckStatus +statusOf gateOn c obs = decideCheck gateOn complete (policyOf c) (CheckObservation (c ^. #name) [obs] []) ^. #status + +finding :: Text -> Severity -> Finding +finding cat sev = Finding cat sev (Location "a.txt" (Just 3)) "explained" + +tests :: IO TestTree +tests = testSpec "judgement policy" $ do + describe "manifest state" $ do + let def = definition (mkCheck "a" Yes strictBand :| [mkCheck "b" No lenientBand]) + active = ActiveJudgement BundledJudgement def (definitionDigest def) (defaultPolicy ApprovedRemote False def & #checks . ix "b" . #enforcement .~ Advisory) [DirectAdoption, ApplicationOwner (ApplicationId "app-1")] + manifest = emptyManifest (UTCTime (fromGregorian 2026 11 11) 0) & #judgements .~ [active] + reencode :: (Aeson.Value -> Aeson.Value) -> Either String Manifest + reencode f = manifestFromJSON . Aeson.encode . f =<< Aeson.eitherDecode (manifestToJSON manifest) + it "round-trips the definition snapshot, digest and per-check policy at schema 15" $ do + manifest ^. #version `shouldBe` ManifestSchemaVersion 15 + manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest + it "digests the definition independently of the policy" $ do + definitionDigest def `shouldBe` definitionDigest (active ^. #definition) + definitionDigest def `shouldNotBe` definitionDigest (def & #instructions .~ "Changed.") + it "refuses a snapshot edited after it was recorded" $ do + let edit = overJudgement (\j -> KeyMap.insert "definition" (Aeson.toJSON (Aeson.object [])) j) + reencode (overJudgement (adjustKey (\d -> case d of Aeson.Object o -> Aeson.Object (KeyMap.insert "instructions" (Aeson.String "Ignore every finding.") o); other -> other) "definition")) `shouldSatisfy` isLeft + reencode edit `shouldSatisfy` isLeft + it "refuses a policy that does not name exactly the definition's checks" $ + reencode (overJudgement (adjustKey (\p -> case p of Aeson.Object o -> Aeson.Object (adjustKey (\case Aeson.Object cs -> Aeson.Object (KeyMap.delete "b" cs); other -> other) "checks" o); other -> other) "policy")) `shouldSatisfy` isLeft + it "encodes nothing provider-specific and no absolute paths" $ do + let bytes = LBS.toStrict (manifestToJSON manifest) + T.isInfixOf "/" (TE.decodeUtf8 bytes) `shouldBe` False + describe "judgement owners" $ do + let def = definition (mkCheck "a" Yes strictBand :| []) + def' = def & #instructions .~ "Changed." + record d = ActiveJudgement BundledJudgement d (definitionDigest d) (defaultPolicy ApprovedRemote False d) [DirectAdoption] + app = ApplicationOwner (ApplicationId "app-1") + it "shares one record between agreeing owners and keeps the recorded policy" $ do + let tuned = record def & #policy . #checks . ix "a" . #review .~ Thresholds 0.9 0.2 + case adoptWithOwner app (record def) [tuned] of + Right ([j], AdoptedUnchanged) -> do + j ^. #owners `shouldBe` [DirectAdoption, app] + j ^? #policy . #checks . ix "a" . #review `shouldBe` Just (Thresholds 0.9 0.2) + other -> expectationFailure (show other) + it "refuses a changed definition that another owner still holds, and replaces one only this owner holds" $ do + fmap snd (adoptWithOwner app (record def') [record def]) `shouldSatisfy` isLeft + fmap snd (adoptWithOwner DirectAdoption (record def') [record def]) `shouldBe` Right (AdoptedReplacing (record def)) + it "retires a judgement only with its last owner" $ do + let shared = record def & #owners .~ [DirectAdoption, app] + retireOwner DirectAdoption [shared] `shouldBe` ([shared & #owners .~ [app]], []) + retireOwner app [shared & #owners .~ [app]] `shouldBe` ([], ["demo"]) + it "names a removed judgement, an advisory check and a raised threshold as weakenings" $ do + let base = record def + loosened = base & #policy . #checks . ix "a" . #review . #blockAt .~ 0.8 & #policy . #checks . ix "a" . #enforcement .~ Advisory + policyWeakenings [base] [base] `shouldBe` [] + policyWeakenings [base] [] `shouldBe` ["judgement 'demo' is no longer active"] + policyWeakenings [base] [loosened] `shouldBe` ["check 'a' of 'demo' is now advisory", "check 'a' of 'demo' blocks at 0.80 instead of 0.50"] + policyWeakenings [loosened] [base] `shouldBe` [] + it "drops application owners whose application is no longer recorded" $ do + let m = emptyManifest (UTCTime (fromGregorian 2026 11 11) 0) & #judgements .~ [record def & #owners .~ [app]] + pruneJudgementOwners m `shouldBe` (m & #judgements .~ [], ["demo"]) + + describe "judgement references" $ do + let refsOf file body = withSystemTempDirectory "seihou-judgement-refs" $ \dir -> do + cwd <- getCurrentDirectory + writeFile (dir file) ("let S = " <> cwd <> "/../schema/package.dhall in " <> body) + evalJudgementRefsFromFile (dir file) + it "decodes a module's references with their source and condition" $ + refsOf "module.dhall" "S.Module::{ name = \"m\", judgements = [ S.JudgementRef::{ name = \"security-review\", when = Some \"Eq ci true\" }, S.JudgementRef::{ name = \"docs-review\", source = Some \"https://example.com/r.git\" } ] }" + `shouldReturn` Right [JudgementRef "security-review" Nothing (Just "Eq ci true"), JudgementRef "docs-review" (Just "https://example.com/r.git") Nothing] + it "reads none from a module that omits the field or predates it" $ do + refsOf "module.dhall" "S.Module::{ name = \"m\" }" `shouldReturn` Right [] + refsOf "module.dhall" "{ name = \"legacy\" }" `shouldReturn` Right [] + it "decodes a recipe's references" $ + refsOf "recipe.dhall" "S.Recipe::{ name = \"r\", modules = [ S.Dependency::{ module = \"m\" } ], judgements = [ S.JudgementRef::{ name = \"security-review\" } ] }" + `shouldReturn` Right [JudgementRef "security-review" Nothing Nothing] + + describe "decoding judgement.dhall" $ do + let decode body = withSystemTempDirectory "seihou-judgement" $ \dir -> do + cwd <- getCurrentDirectory + let file = dir "judgement.dhall" + writeFile file ("let S = " <> cwd <> "/../schema/package.dhall in " <> body) + evalJudgementFromFile file + it "fills every default from the schema for a one-check judgement" $ do + r <- decode "S.Judgement::{ name = \"docs\", checks = [ S.Check::{ name = \"stale\", question = \"Is it stale?\" } ] }" + case r of + Left e -> expectationFailure (show e) + Right d -> do + d ^. #evidence `shouldBe` defaultEvidenceDeclaration + d ^. #limits `shouldBe` defaultCoverageLimits + d ^. #deterministicChecks `shouldBe` [] + let c = NE.head (d ^. #checks) + (c ^. #concernWhen, c ^. #enforcement, c ^. #blockingSeverity, c ^. #useGate) `shouldBe` (Yes, Enforced, High, True) + (c ^. #review, c ^. #gate) `shouldBe` (Thresholds 0.7 0.3, Thresholds 0.9 0.05) + validateDefinition d `shouldBe` Right () + it "decodes concern direction, enforcement, categories, thresholds and deterministic checks" $ do + r <- + decode + ( "S.Judgement::{ name = \"customer-data-review\", deterministicChecks = [ S.DeterministicCheck.SecretScan ], " + <> "evidence = S.JudgementEvidence::{ scopes = [ S.EvidenceScope.StagedChanges ], include = [ \"docs/**\" ] }, " + <> "checks = [ S.Check::{ name = \"undocumented-export\", question = \"Do the notes mention every export?\", " + <> "concernWhen = S.Answer.No, enforcement = S.Enforcement.Advisory, blockAt = 0.8, passAt = 0.4, useGate = False, " + <> "categories = [ S.FindingCategory::{ name = \"export\", severity = S.Severity.Critical } ] } ] }" + ) + case r of + Left e -> expectationFailure (show e) + Right d -> do + d ^. #deterministicChecks `shouldBe` [SecretScan] + d ^. #evidence `shouldBe` EvidenceDeclaration [StagedChangesScope] ["docs/**"] [] + let c = NE.head (d ^. #checks) + (c ^. #concernWhen, c ^. #enforcement, c ^. #review, c ^. #useGate) `shouldBe` (No, Advisory, Thresholds 0.8 0.4, False) + c ^. #categories `shouldBe` [FindingCategory "export" Critical Nothing] + it "rejects a judgement with no checks at decode time" $ do + r <- decode "S.Judgement::{ name = \"empty\", checks = [] : List S.Check.Type }" + r `shouldSatisfy` isLeft + it "leaves an inverted threshold pair to validation, which names the check" $ do + r <- decode "S.Judgement::{ name = \"x\", checks = [ S.Check::{ name = \"c\", question = \"q?\", blockAt = 0.2, passAt = 0.5 } ] }" + fmap validateDefinition r `shouldSatisfy` \case + Right (Left e) -> e ^. #code == "judgement_threshold_inverted" + _ -> False + + let c = mkCheck "c" Yes strictBand + describe "definition validation" $ do + it "accepts a one-check definition" $ + validateDefinition (definition (c :| [])) `shouldSatisfy` isRight + it "rejects duplicate check names" $ + validateDefinition (definition (c :| [c])) `shouldSatisfy` isLeft + it "rejects thresholds outside 0 to 1 and inverted pairs" $ do + validateDefinition (definition (mkCheck "c" Yes (Thresholds 1.2 0.1) :| [])) `shouldSatisfy` isLeft + validateDefinition (definition (mkCheck "c" Yes (Thresholds 0.3 0.4) :| [])) `shouldSatisfy` isLeft + validateDefinition (definition ((c & #gate .~ Thresholds 0.1 0.2) :| [])) `shouldSatisfy` isLeft + it "accepts equal thresholds, which remove the needs-review band" $ + validateDefinition (definition (mkCheck "c" Yes (Thresholds 0.4 0.4) :| [])) `shouldSatisfy` isRight + it "rejects duplicate categories and malformed names" $ do + validateDefinition (definition ((c & #categories .~ [category "x" Low, category "x" High]) :| [])) `shouldSatisfy` isLeft + validateDefinition (definition ((c & #name .~ "Bad Name") :| [])) `shouldSatisfy` isLeft + it "rejects escaping path patterns" $ + validateDefinition (definition (c :| []) & #evidence . #exclude .~ ["../x"]) `shouldSatisfy` isLeft + + describe "concern direction" $ do + it "is the identity when yes is the concern and the complement when no is" $ do + concernProbability Yes 0.8 `shouldBe` 0.8 + concernProbability No 0.8 `shouldSatisfy` (\p -> abs (p - 0.2) < 1e-9) + + describe "review band" $ do + it "passes at or below the pass threshold" $ + statusOf False c (chunkWith Nothing (Just (Right (reviewAt 0.1)))) `shouldBe` CheckPassed + it "needs review strictly between the thresholds" $ + statusOf False c (chunkWith Nothing (Just (Right (reviewAt 0.3)))) `shouldBe` CheckNeedsReview + it "blocks at or above the block threshold, even without a finding" $ + statusOf False c (chunkWith Nothing (Just (Right (reviewAt 0.5)))) `shouldBe` CheckBlocked + it "blocks on a blocking located finding regardless of a low probability" $ + statusOf False c (chunkWith Nothing (Just (Right (ReviewObservation 0.01 [finding "credential" Critical] False)))) `shouldBe` CheckBlocked + it "does not block on a finding below the blocking severity" $ + statusOf False c (chunkWith Nothing (Just (Right (ReviewObservation 0.01 [finding "style" Low] False)))) `shouldBe` CheckPassed + it "needs review when the model asks for it, even at a low probability" $ + statusOf False c (chunkWith Nothing (Just (Right (ReviewObservation 0.0 [] True)))) `shouldBe` CheckNeedsReview + it "fails on an out-of-range probability or a failed review" $ do + statusOf False c (chunkWith Nothing (Just (Right (reviewAt 1.5)))) `shouldBe` CheckFailed + statusOf False c (chunkWith Nothing (Just (Left "malformed reply"))) `shouldBe` CheckFailed + it "cannot pass with incomplete coverage" $ + decideCheck False (Coverage [] [] [("big.bin", "binary")]) (policyOf c) (CheckObservation "c" [chunkWith Nothing (Just (Right (reviewAt 0.0)))] []) ^. #status + `shouldBe` CheckFailed + + describe "two checks with different thresholds" $ + it "reach different outcomes from the same probability" $ do + let a = mkCheck "a" Yes strictBand + b = mkCheck "b" Yes lenientBand + def = definition (a :| [b]) + obs = JudgementObservation complete [] [] [CheckObservation n [chunkWith Nothing (Just (Right (reviewAt 0.7)))] [] | n <- ["a", "b"]] False + d = decideJudgement def (defaultPolicy ApprovedRemote False def) obs + map (^. #status) (d ^. #checks) `shouldBe` [CheckBlocked, CheckNeedsReview] + d ^. #status `shouldBe` Blocked + + describe "advisory checks" $ + it "report a block without failing the judgement" $ do + let a = mkCheck "a" Yes strictBand & #enforcement .~ Advisory + def = definition (a :| []) + obs = JudgementObservation complete [] [] [CheckObservation "a" [chunkWith Nothing (Just (Right (reviewAt 0.9)))] []] False + d = decideJudgement def (defaultPolicy ApprovedRemote False def) obs + map (^. #status) (d ^. #checks) `shouldBe` [CheckBlocked] + d ^. #status `shouldBe` Passed + + describe "gate" $ do + it "clears a check at or below the gate pass threshold with no review" $ do + let d = decideCheck True complete (policyOf c) (CheckObservation "c" [chunkWith (Just (GateAnswered 0.05)) Nothing] []) + d ^. #status `shouldBe` CheckPassed + map (^. #decidedBy) (d ^. #chunks) `shouldBe` [DecidedByGate] + it "escalates above the gate pass threshold and lets the review decide" $ do + statusOf True c (chunkWith (Just (GateAnswered 0.3)) (Just (Right (reviewAt 0.05)))) `shouldBe` CheckPassed + statusOf True c (chunkWith (Just (GateAnswered 0.3)) (Just (Right (reviewAt 0.7)))) `shouldBe` CheckBlocked + it "turns a clean review after a gate block into needs-review" $ + statusOf True c (chunkWith (Just (GateAnswered 0.9)) (Just (Right (reviewAt 0.0)))) `shouldBe` CheckNeedsReview + it "fails an escalated check whose review never ran" $ + statusOf True c (chunkWith (Just (GateAnswered 0.3)) Nothing) `shouldBe` CheckFailed + it "escalates visibly when the gate fails" $ do + let d = decideCheck True complete (policyOf c) (CheckObservation "c" [chunkWith (Just (GateFailed "timeout")) (Just (Right (reviewAt 0.0)))] []) + d ^. #status `shouldBe` CheckPassed + d ^. #reasons `shouldContain` [GateUnavailable "timeout"] + it "is ignored when the policy does not permit it or the check opts out" $ do + statusOf False c (chunkWith (Just (GateAnswered 0.0)) Nothing) `shouldBe` CheckFailed + statusOf True (c & #useGate .~ False) (chunkWith (Just (GateAnswered 0.0)) Nothing) `shouldBe` CheckFailed + + describe "a check whose concern is no" $ + it "blocks on a low probability of yes and passes on a high one, for gate and review" $ do + let n = mkCheck "tests" No strictBand + viaReview pYes = statusOf False n (chunkWith Nothing (Just (Right (reviewAt (concernProbability No pYes))))) + viaGate pYes = statusOf True n (chunkWith (Just (GateAnswered (concernProbability No pYes))) Nothing) + viaReview 0.1 `shouldBe` CheckBlocked + viaReview 0.95 `shouldBe` CheckPassed + viaGate 0.99 `shouldBe` CheckPassed + viaGate 0.1 `shouldBe` CheckFailed + + describe "judgement combination" $ do + let a = mkCheck "a" Yes strictBand + b = mkCheck "b" Yes strictBand + def = definition (a :| [b]) + pol = defaultPolicy ApprovedRemote False def + obsFor pa pb = JudgementObservation complete [] [] [CheckObservation "a" [pa] [], CheckObservation "b" [pb] []] False + ok = chunkWith Nothing (Just (Right (reviewAt 0.0))) + it "orders block above needs-review above error" $ do + decideJudgement def pol (obsFor (chunkWith Nothing (Just (Left "x"))) (chunkWith Nothing (Just (Right (reviewAt 0.3))))) ^. #status `shouldBe` NeedsReview + decideJudgement def pol (obsFor (chunkWith Nothing (Just (Left "x"))) ok) ^. #status `shouldBe` Failed + decideJudgement def pol (obsFor (chunkWith Nothing (Just (Right (reviewAt 0.3)))) (chunkWith Nothing (Just (Right (reviewAt 0.9))))) ^. #status `shouldBe` Blocked + decideJudgement def pol (obsFor ok ok) ^. #status `shouldBe` Passed + it "blocks on any deterministic finding regardless of probabilities" $ do + let obs = obsFor ok ok & #deterministic .~ [DeterministicFinding SecretScan "generic-api-key" (Location "a.txt" (Just 1))] + decideJudgement def pol obs ^. #status `shouldBe` Blocked + it "reports NoChanges for empty evidence rather than a pass" $ + decideJudgement def pol (JudgementObservation (Coverage [] [] []) [] [] [] True) ^. #status `shouldBe` NoChanges + it "fails a check that produced no observation" $ + decideJudgement def pol (JudgementObservation complete [] [] [CheckObservation "a" [ok] []] False) ^. #status `shouldBe` Failed + it "errors on a transmission-safeguard refusal without claiming a finding" $ do + let obs = JudgementObservation complete [] [] [CheckObservation "a" [] ["'a.txt' was not sent: the transmission safeguard flagged it"], CheckObservation "b" [ok] []] False + d = decideJudgement def pol obs + d ^. #status `shouldBe` Failed + concatMap (^. #findings) (d ^. #checks) `shouldBe` [] + + describe "output validation" $ do + let idx = EvidenceIndex (Map.fromList [("a.txt", 10)]) + raw fs = RawReview 0.2 fs False + it "accepts declared categories at real locations, taking severity from the author" $ + fmap (map (^. #severity) . (^. #findings)) (validateReview defaultCoverageLimits c idx (raw [RawFinding "credential" "a.txt" (Just 2) "x"])) + `shouldBe` Right [Critical] + it "rejects undeclared categories, invented files and out-of-range lines" $ do + validateReview defaultCoverageLimits c idx (raw [RawFinding "other" "a.txt" Nothing "x"]) `shouldSatisfy` isLeft + validateReview defaultCoverageLimits c idx (raw [RawFinding "credential" "b.txt" Nothing "x"]) `shouldSatisfy` isLeft + validateReview defaultCoverageLimits c idx (raw [RawFinding "credential" "a.txt" (Just 11) "x"]) `shouldSatisfy` isLeft + it "rejects a missing or out-of-range probability and oversized output" $ do + validateReview defaultCoverageLimits c idx (RawReview (-0.1) [] False) `shouldSatisfy` isLeft + validateReview (defaultCoverageLimits & #maxFindings .~ 1) c idx (raw (replicate 2 (RawFinding "style" "a.txt" Nothing "x"))) `shouldSatisfy` isLeft + +-- | Apply a change to the single recorded judgement object in an encoded +-- manifest. +overJudgement :: (KeyMap.KeyMap Aeson.Value -> KeyMap.KeyMap Aeson.Value) -> Aeson.Value -> Aeson.Value +overJudgement f = \case + Aeson.Object top -> Aeson.Object (adjustKey (\case Aeson.Array js -> Aeson.Array (fmap (\case Aeson.Object j -> Aeson.Object (f j); other -> other) js); other -> other) "judgements" top) + other -> other + +adjustKey :: (Aeson.Value -> Aeson.Value) -> KeyMap.Key -> KeyMap.KeyMap Aeson.Value -> KeyMap.KeyMap Aeson.Value +adjustKey f k m = maybe m (\v -> KeyMap.insert k (f v) m) (KeyMap.lookup k m) diff --git a/test/Seihou/Core/ModuleSpec.hs b/test/Seihou/Core/ModuleSpec.hs --- a/test/Seihou/Core/ModuleSpec.hs +++ b/test/Seihou/Core/ModuleSpec.hs @@ -189,6 +189,45 @@ Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) Right _ -> expectationFailure "Expected validation failure" + it "rejects a destination in Seihou's own state" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + goodModule + & #steps + .~ [Step Template "README.md.tpl" ".seihou/manifest.json" Nothing Nothing Managed] + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "step destination path targets Seihou's own state at .seihou/manifest.json" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "accepts a destination in the module's own .seihou directory" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let good = + goodModule + & #steps + .~ [Step Template "README.md.tpl" ".seihou/test-module/helper.txt" Nothing Nothing Managed] + result <- validateModule tmpDir good + either (\err -> expectationFailure ("Expected success, got: " <> show err)) (const (pure ())) result + + it "still loads a module with a legacy file directly under .seihou" $ do + -- The own-directory rule is enforced at generation, not load, so an + -- existing application of such a module can still be removed. + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let legacy = + goodModule + & #steps + .~ [Step Template "README.md.tpl" ".seihou/test-module.conf" Nothing Nothing Managed] + result <- validateModule tmpDir legacy + either (\err -> expectationFailure ("Expected success, got: " <> show err)) (const (pure ())) result + it "rejects absolute destination path" $ do withSystemTempDirectory "seihou-test" $ \tmpDir -> do createDirectoryIfMissing True (tmpDir "files") diff --git a/test/Seihou/Core/PathSpec.hs b/test/Seihou/Core/PathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/PathSpec.hs @@ -0,0 +1,110 @@ +module Seihou.Core.PathSpec (tests) where + +import Control.Monad (forM_) +import Data.Maybe (isJust) +import Data.Text qualified as T +import Seihou.Core.Path +import Seihou.Prelude +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +isControl :: ProjectPathClass -> Bool +isControl (ControlPath _) = True +isControl _ = False + +tests :: IO TestTree +tests = testSpec "project path classification" $ do + describe "classifyProjectPath" $ do + it "treats paths outside .seihou and .git as ordinary" $ + forM_ ["README.md", "docs/.seihou-notes", "src/.seihou/x", "seihou/manifest.json"] $ \path -> + classifyProjectPath path `shouldBe` OrdinaryProjectPath + + it "treats everything under .git as Git control data" $ + forM_ [".git", ".git/config", ".GIT/HEAD", "./.git/index"] $ \path -> + classifyProjectPath path `shouldBe` ControlPath "path targets Git control data" + + it "treats Seihou's reserved entries as control data, in any case and either separator" + $ forM_ + [ ".seihou/manifest.json", + ".seihou/manifest.json.tmp", + ".seihou/Manifest.JSON", + ".SEIHOU/manifest.json", + ".seihou/baselines/abc", + ".seihou/transactions/x/journal.json", + ".seihou/transactions-quarantine/x", + ".seihou/modules/demo/module.dhall", + ".seihou/context", + ".seihou/config.dhall", + ".seihou/trace.jsonl", + ".seihou/.migrate-signal", + ".seihou\\baselines\\abc", + ".seihou//baselines/abc", + ".seihou/./manifest.json" + ] + $ \path -> classifyProjectPath path `shouldSatisfy` isControl + + it "names the reserved entry as the path spells it" $ + classifyProjectPath ".SEIHOU/Manifest.JSON" + `shouldBe` ControlPath "path targets Seihou's own state at .SEIHOU/Manifest.JSON" + + it "reports other .seihou entries as module state areas" $ do + classifyProjectPath ".seihou/docs-mori-bootstrap/bootstrap-docs.py" + `shouldBe` ModuleStatePath "docs-mori-bootstrap" True + classifyProjectPath ".seihou/gcp-kube-env.conf" `shouldBe` ModuleStatePath "gcp-kube-env.conf" False + classifyProjectPath ".seihou/demo/" `shouldBe` ModuleStatePath "demo" False + + it "recognises the .seihou directory itself" $ + forM_ [".seihou", ".SEIHOU", ".seihou/", "./.seihou"] $ \path -> + classifyProjectPath path `shouldBe` SeihouRootDirectory + + it "keeps the reserved list to names that are not valid module names, except legacy entries" $ + -- Legacy entries predate the rule; new entries must not look like module names. + filter (T.all (\c -> (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '-')) reservedSeihouEntries + `shouldBe` ["baselines", "transactions", "transactions-quarantine", "modules", "context"] + + describe "control predicates" $ do + it "refuses the .seihou directory as a file but allows it as a directory" $ do + isControlFileTarget ".seihou" `shouldBe` True + isControlDirectory ".seihou" `shouldBe` False + + it "refuses control data as both files and directories" $ + forM_ [".git", ".seihou/baselines", ".seihou/manifest.json"] $ \path -> do + isControlFileTarget path `shouldBe` True + isControlDirectory path `shouldBe` True + + it "allows ordinary and module-state paths" $ + forM_ ["src/x", ".seihou/demo", ".seihou/demo/helper.txt"] $ \path -> do + isControlFileTarget path `shouldBe` False + isControlDirectory path `shouldBe` False + controlPathReason FileTarget path `shouldBe` Nothing + + describe "ownStateDirectoryViolation" $ do + let violation = ownStateDirectoryViolation "demo" + + it "accepts ordinary paths and files inside the module's own directory" $ + forM_ [".seihou/demo/a/b.txt", ".seihou/demo/helper.txt", "src/x"] $ \path -> + violation FileTarget path `shouldBe` Nothing + + it "refuses other .seihou file targets, naming the allowed directory" $ do + forM_ [".seihou/demo", ".seihou", ".seihou/other/x", ".Seihou/demo/x", ".seihou/Demo/x", ".seihou/demo.conf"] $ \path -> + violation FileTarget path `shouldSatisfy` isJust + violation FileTarget ".seihou/other/x" + `shouldBe` Just ".seihou/other/x is outside this module's state directory; a module may write under .seihou/ only inside .seihou/demo/" + + it "refuses Seihou's own state with the control reason" $ + violation FileTarget ".seihou/manifest.json" + `shouldBe` Just "path targets Seihou's own state at .seihou/manifest.json" + + it "gives a module named after a reserved entry no state directory" $ + ownStateDirectoryViolation "modules" FileTarget ".seihou/modules/x" + `shouldBe` Just "path targets Seihou's own state at .seihou/modules" + + it "accepts the .seihou directory and the module's own directory as directory operands" $ do + violation DirectoryOperand ".seihou" `shouldBe` Nothing + violation DirectoryOperand ".seihou/demo" `shouldBe` Nothing + violation DirectoryOperand ".seihou/demo/sub" `shouldBe` Nothing + + it "refuses other directories under .seihou" $ do + violation DirectoryOperand ".seihou/other" `shouldSatisfy` isJust + violation DirectoryOperand ".seihou/baselines" `shouldSatisfy` isJust diff --git a/test/Seihou/Core/RegistryEmitSpec.hs b/test/Seihou/Core/RegistryEmitSpec.hs --- a/test/Seihou/Core/RegistryEmitSpec.hs +++ b/test/Seihou/Core/RegistryEmitSpec.hs @@ -47,7 +47,8 @@ } ], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } roundTrip reg @@ -67,7 +68,8 @@ ], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } roundTrip reg @@ -87,7 +89,8 @@ ], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } roundTrip reg @@ -107,7 +110,8 @@ ], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } roundTrip reg @@ -119,7 +123,8 @@ modules = [], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } roundTrip reg @@ -170,7 +175,8 @@ description = Just "Prompt entry", tags = ["agent"] } - ] + ], + judgements = [] } roundTrip reg diff --git a/test/Seihou/Core/RegistrySpec.hs b/test/Seihou/Core/RegistrySpec.hs --- a/test/Seihou/Core/RegistrySpec.hs +++ b/test/Seihou/Core/RegistrySpec.hs @@ -184,7 +184,8 @@ modules = [RegistryEntry (ModuleName "mod-a") Nothing "mod-a" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg errs `shouldBe` [] @@ -200,7 +201,8 @@ modules = [RegistryEntry (ModuleName "Bad_Name") Nothing "Bad_Name" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg length errs `shouldSatisfy` (> 0) @@ -215,7 +217,8 @@ modules = [RegistryEntry (ModuleName "missing") Nothing "nonexistent" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg length errs `shouldSatisfy` (> 0) @@ -230,7 +233,8 @@ modules = [RegistryEntry (ModuleName "bad-path") Nothing "../escape" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg any ("must not contain" `isInfixOf`) (map show errs) `shouldBe` True @@ -247,7 +251,8 @@ modules = [RegistryEntry (ModuleName "mod-a") (Just "1.0.0") "mod-a" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } lookups = [(ModuleEntry, ModuleName "mod-a", Just "1.0.0")] report <- validateRegistryFull tmpDir reg lookups @@ -268,7 +273,8 @@ modules = [RegistryEntry (ModuleName "mod-a") Nothing "mod-a" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } lookups = [(ModuleEntry, ModuleName "mod-a", Just "1.0.0")] report <- validateRegistryFull tmpDir reg lookups @@ -287,7 +293,8 @@ modules = [RegistryEntry (ModuleName "mod-a") (Just "1.0.0") "mod-a" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } lookups = [(ModuleEntry, ModuleName "mod-a", Just "2.0.0")] report <- validateRegistryFull tmpDir reg lookups @@ -306,7 +313,8 @@ modules = [RegistryEntry (ModuleName "Bad_Name") Nothing "Bad_Name" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } lookups = [(ModuleEntry, ModuleName "Bad_Name", Nothing)] report <- validateRegistryFull tmpDir reg lookups @@ -322,7 +330,8 @@ modules = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } report <- validateRegistryFull tmpDir reg [] let structurals = [msg | StructuralError msg <- report ^. #issues] @@ -345,7 +354,8 @@ ], recipes = [], blueprints = [], - prompts = [] + prompts = [], + judgements = [] } lookups = [ (ModuleEntry, ModuleName "good", Just "1.0.0"), @@ -452,7 +462,8 @@ modules = [], recipes = [], blueprints = [RegistryEntry (ModuleName "Bad_Bp") Nothing "Bad_Bp" Nothing []], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg any ("blueprint name must match" `isInfixOf`) (map show errs) `shouldBe` True @@ -466,7 +477,8 @@ modules = [], recipes = [], blueprints = [RegistryEntry (ModuleName "ghost") Nothing "ghost" Nothing []], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg any ("missing blueprint.dhall" `isInfixOf`) (map show errs) `shouldBe` True @@ -480,7 +492,8 @@ modules = [], recipes = [], blueprints = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg any ("blueprint path must not contain" `isInfixOf`) (map show errs) `shouldBe` True @@ -505,7 +518,8 @@ [ RegistryEntry (ModuleName "duped") Nothing "shared-bp1" Nothing [], RegistryEntry (ModuleName "other") Nothing "shared-bp2" Nothing [] ], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg any ("appears as both a module and a blueprint" `isInfixOf`) (map show errs) @@ -528,7 +542,8 @@ modules = [RegistryEntry (ModuleName "tripled") Nothing "trip-m" Nothing []], recipes = [RegistryEntry (ModuleName "tripled") Nothing "trip-r" Nothing []], blueprints = [RegistryEntry (ModuleName "tripled") Nothing "trip-b" Nothing []], - prompts = [] + prompts = [], + judgements = [] } errs <- validateRegistry tmpDir reg let messages = map show errs @@ -546,7 +561,8 @@ blueprints = [ RegistryEntry (ModuleName "bp-stale") (Just "0.1.0") "blueprints/bp-stale" Nothing [] ], - prompts = [] + prompts = [], + judgements = [] } lookups = [(BlueprintEntry, ModuleName "bp-stale", Just "0.2.0")] SyncReport diffs updated = computeRegistrySync reg lookups @@ -575,7 +591,8 @@ [ RegistryEntry (ModuleName "bp-a") (Just "1.0.0") "bp-a" Nothing [], RegistryEntry (ModuleName "bp-b") (Just "1.0.0") "bp-b" Nothing [] ], - prompts = [] + prompts = [], + judgements = [] } lookups = [ (BlueprintEntry, ModuleName "bp-a", Just "1.0.0"), @@ -597,7 +614,8 @@ modules = [], recipes = [], blueprints = [], - prompts = [RegistryEntry (ModuleName "Bad_Prompt") Nothing "Bad_Prompt" Nothing []] + prompts = [RegistryEntry (ModuleName "Bad_Prompt") Nothing "Bad_Prompt" Nothing []], + judgements = [] } errs <- validateRegistry tmpDir reg any ("prompt name must match" `isInfixOf`) (map show errs) `shouldBe` True @@ -611,7 +629,8 @@ modules = [], recipes = [], blueprints = [], - prompts = [RegistryEntry (ModuleName "ghost") Nothing "ghost" Nothing []] + prompts = [RegistryEntry (ModuleName "ghost") Nothing "ghost" Nothing []], + judgements = [] } errs <- validateRegistry tmpDir reg any ("missing prompt.dhall" `isInfixOf`) (map show errs) `shouldBe` True @@ -625,7 +644,8 @@ modules = [], recipes = [], blueprints = [], - prompts = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []] + prompts = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []], + judgements = [] } errs <- validateRegistry tmpDir reg any ("prompt path must not contain" `isInfixOf`) (map show errs) `shouldBe` True @@ -655,7 +675,8 @@ [ RegistryEntry (ModuleName "as-module") Nothing "shared-prompt1" Nothing [], RegistryEntry (ModuleName "as-recipe") Nothing "shared-prompt2" Nothing [], RegistryEntry (ModuleName "as-blueprint") Nothing "shared-prompt3" Nothing [] - ] + ], + judgements = [] } errs <- validateRegistry tmpDir reg let messages = map show errs @@ -673,7 +694,8 @@ blueprints = [], prompts = [ RegistryEntry (ModuleName "prompt-stale") (Just "0.1.0") "prompts/prompt-stale" Nothing [] - ] + ], + judgements = [] } lookups = [(PromptEntry, ModuleName "prompt-stale", Just "0.2.0")] SyncReport diffs updated = computeRegistrySync reg lookups @@ -702,7 +724,8 @@ prompts = [ RegistryEntry (ModuleName "prompt-a") (Just "1.0.0") "prompt-a" Nothing [], RegistryEntry (ModuleName "prompt-b") (Just "1.0.0") "prompt-b" Nothing [] - ] + ], + judgements = [] } lookups = [ (PromptEntry, ModuleName "prompt-a", Just "1.0.0"), diff --git a/test/Seihou/Core/RegistrySyncSpec.hs b/test/Seihou/Core/RegistrySyncSpec.hs --- a/test/Seihou/Core/RegistrySyncSpec.hs +++ b/test/Seihou/Core/RegistrySyncSpec.hs @@ -162,5 +162,6 @@ modules = mods, recipes = recs, blueprints = [], - prompts = [] + prompts = [], + judgements = [] } diff --git a/test/Seihou/Dhall/MigrationDecoderSpec.hs b/test/Seihou/Dhall/MigrationDecoderSpec.hs --- a/test/Seihou/Dhall/MigrationDecoderSpec.hs +++ b/test/Seihou/Dhall/MigrationDecoderSpec.hs @@ -21,6 +21,32 @@ spec :: Spec spec = do describe "moduleDecoder migrations field" $ do + it "decodes the extended union through evalModuleFromFile" $ do + let extended = T.replace " >" " | RemoveLine : { path : Text, line : Text } >" migrationOpType + removal = "(" <> extended <> ").RemoveLine { path = \".gitignore\", line = \".envrc\" }" + withModuleDhall (oneMigration removal) $ \result -> + case result of + Right m -> map (^. #ops) (m ^. #migrations) `shouldBe` [[RemoveLine ".gitignore" ".envrc"]] + Left err -> expectationFailure (show err) + it "decodes all older constructors in the extended union" $ do + let cases = [(moveFileOp, MoveFile "old/Path.hs" "new/Path.hs"), (moveDirOp, MoveDir "app" "src"), (deleteFileOp, DeleteFile "Setup.hs"), (deleteDirOp, DeleteDir "obsolete"), (runCommandNoWorkDir, RunCommand "echo hi" Nothing)] + mapM_ + ( \(old, expectedOp) -> do + let extended = T.replace " >" " | RemoveLine : { path : Text, line : Text } >" (oneMigration old) + withModuleDhall extended $ \result -> case result of + Right m -> map (^. #ops) (m ^. #migrations) `shouldBe` [[expectedOp]] + Left err -> expectationFailure (show err) + ) + cases + it "decodes an empty extended migrations list" $ + withModuleDhall (T.replace " >" " | RemoveLine : { path : Text, line : Text } >" emptyMigrations) $ \result -> + case result of + Right m -> m ^. #migrations `shouldBe` [] + Left err -> expectationFailure (show err) + it "refuses an unsupported migration constructor" $ + withModuleDhall (oneMigration ("(" <> T.replace " >" " | Unsupported : Text >" migrationOpType <> ").Unsupported \"x\"")) $ \result -> + result `shouldSatisfy` either (const True) (const False) + it "decodes a module with no migrations field as []" $ withModuleDhall noMigrationsField $ \result -> case result of diff --git a/test/Seihou/Engine/DiffSpec.hs b/test/Seihou/Engine/DiffSpec.hs --- a/test/Seihou/Engine/DiffSpec.hs +++ b/test/Seihou/Engine/DiffSpec.hs @@ -59,7 +59,8 @@ blueprint = base ^. #blueprint, seeds = base ^. #seeds, checkoutOutputs = base ^. #checkoutOutputs, - blueprintMigrations = base ^. #blueprintMigrations + blueprintMigrations = base ^. #blueprintMigrations, + judgements = base ^. #judgements } spec :: Spec diff --git a/test/Seihou/Engine/MigrateSpec.hs b/test/Seihou/Engine/MigrateSpec.hs --- a/test/Seihou/Engine/MigrateSpec.hs +++ b/test/Seihou/Engine/MigrateSpec.hs @@ -23,6 +23,8 @@ MigrationOpInstance (..), classifyMigration, executeMigration, + removeExactLine, + validateSeedMigration, ) import Seihou.Manifest.Hash (hashContent) import Seihou.Manifest.Types (emptyManifest) @@ -105,6 +107,54 @@ spec :: Spec spec = do + describe "removeExactLine" $ do + it "preserves CRLF, LF, whitespace variants and the final unterminated line" $ + removeExactLine ".envrc" ".envrc\r\n.envrc.local\r\n .envrc\n/.envrc\n.envrc\n# comment" `shouldBe` ".envrc.local\r\n .envrc\n/.envrc\n# comment" + it "removes duplicate matches and an unterminated match" $ + removeExactLine ".envrc" ".envrc\n.envrc" `shouldBe` "" + it "preserves a nonmatching final carriage return" $ + removeExactLine ".envrc" ".envrc\r" `shouldBe` ".envrc\r" + it "is idempotent" $ + removeExactLine ".envrc" (removeExactLine ".envrc" "x\n.envrc\n") `shouldBe` "x\n" + + describe "RemoveLine execution" $ do + it "preserves unrelated edits without force and retains manifest file metadata" $ do + let manifest = mkManifest [(".gitignore", ".envrc\noriginal\n")] + fs = mkFS [(".gitignore", ".envrc\noriginal\nuser edit\n")] + plan = runClassify fs manifest (chain1 "1.0.0" "2.0.0" [RemoveLine ".gitignore" ".envrc"]) + (result, finalFS) = runExecute fs manifest plan False + Map.lookup ".gitignore" (finalFS ^. #files) `shouldBe` Just "original\nuser edit\n" + fmap (^. #files) result `shouldBe` Right (manifest ^. #files) + it "does not create a missing target" $ do + let manifest = mkManifest [] + fs = mkFS [] + plan = runClassify fs manifest (chain1 "1.0.0" "2.0.0" [RemoveLine ".gitignore" ".envrc"]) + (_, finalFS) = runExecute fs manifest plan False + finalFS `shouldBe` fs + it "rejects a symlink target without editing its referent" $ do + let manifest = mkManifest [] + fs = (mkFS [("real", ".envrc\n")]) & #links .~ Map.singleton ".gitignore" "real" + plan = runClassify fs manifest (chain1 "1.0.0" "2.0.0" [RemoveLine ".gitignore" ".envrc"]) + (result, finalFS) = runExecute fs manifest plan False + result `shouldSatisfy` either (const True) (const False) + finalFS `shouldBe` fs + it "rejects protected seed targets and their parent paths" $ do + mapM_ (\path -> validateSeedMigration (Set.singleton "owned/seed") [RemoveLine path ".envrc"] `shouldSatisfy` either (const True) (const False)) ["owned/seed", "owned"] + it "rejects unsafe paths before reading any target" $ do + mapM_ (\path -> runClassifyResult (mkFS []) (mkManifest []) (chain1 "1.0.0" "2.0.0" [RemoveLine path ".envrc"]) `shouldSatisfy` either (const True) (const False)) ["../outside", "/absolute", ".git/config", ".seihou/manifest.json"] + it "rejects directories and paths through symbolic-link parents" $ do + let fs = (mkFS [("real/ignore", ".envrc\n")]) & #dirs .~ Set.singleton "directory" & #links .~ Map.singleton "linked" "real" + mapM_ + ( \path -> do + let plan = runClassify fs (mkManifest []) (chain1 "1.0.0" "2.0.0" [RemoveLine path ".envrc"]) + (result, finalFS) = runExecute fs (mkManifest []) plan False + result `shouldSatisfy` either (const True) (const False) + finalFS `shouldBe` fs + ) + ["directory", "linked/ignore"] + it "rejects empty and multiline removal arguments" $ do + let manifest = mkManifest [] + mapM_ (\line -> runClassifyResult (mkFS []) manifest (chain1 "1.0.0" "2.0.0" [RemoveLine ".gitignore" line]) `shouldSatisfy` either (const True) (const False)) ["", "a\nb", "a\rb"] describe "classifyMigration" $ do it "marks a move-file safe when disk hash matches manifest" $ do let manifest = mkManifest [("app/Main.hs", "module Main where")] @@ -140,6 +190,24 @@ c = chain1 "1.0.0" "2.0.0" [MoveFile "README.md" "../outside"] result = runClassifyResult fs manifest c result `shouldBe` Left (MigrationUnsafePath "move-file destination" "../outside" "path must not contain '..' segment: ../outside") + + it "rejects a migration path in Seihou's own state" $ do + let manifest = mkManifest [] + fs = mkFS [] + c = chain1 "1.0.0" "2.0.0" [DeleteDir ".seihou/baselines"] + result = runClassifyResult fs manifest c + result `shouldBe` Left (MigrationUnsafePath "delete-dir path" ".seihou/baselines" "path targets Seihou's own state at .seihou/baselines") + + it "rejects a migration that deletes the .seihou directory itself" $ do + let c = chain1 "1.0.0" "2.0.0" [DeleteDir ".seihou"] + runClassifyResult (mkFS []) (mkManifest []) c `shouldSatisfy` either (const True) (const False) + + it "allows moving a legacy .seihou file into the module's own directory" $ do + let manifest = mkManifest [(".seihou/gcp-kube-env.conf", "x")] + fs = mkFS [(".seihou/gcp-kube-env.conf", "x")] + c = chain1 "1.0.0" "2.0.0" [MoveFile ".seihou/gcp-kube-env.conf" ".seihou/gcp-kube-env/env.conf"] + plan = runClassify fs manifest c + (plan ^. #ops) `shouldBe` [MoveFileInst ".seihou/gcp-kube-env.conf" ".seihou/gcp-kube-env/env.conf" MFSafe] it "rejects a run-command workDir with a parent directory segment" $ do let manifest = mkManifest [] diff --git a/test/Seihou/Engine/PlanSpec.hs b/test/Seihou/Engine/PlanSpec.hs --- a/test/Seihou/Engine/PlanSpec.hs +++ b/test/Seihou/Engine/PlanSpec.hs @@ -240,6 +240,26 @@ T.isInfixOf "must be relative" (errs !! 0) `shouldBe` True Right _ -> expectationFailure "Expected Left" + it "compiles a write into the module's own .seihou directory with its parents" $ do + withFixture [("helper.txt.tpl", "content")] $ \baseDir -> do + let modul = stateModule [Step Template "helper.txt.tpl" ".seihou/demo/x" Nothing Nothing Managed] + result <- compilePlan baseDir modul Map.empty + result + `shouldBe` Right [CreateDirOp ".seihou", CreateDirOp ".seihou/demo", WriteFileOp ".seihou/demo/x" "content" Template] + + it "rejects a rendered destination in another .seihou directory" $ do + withFixture [("helper.txt.tpl", "content")] $ \baseDir -> do + let modul = stateModule [Step Template "helper.txt.tpl" ".seihou/{{name}}/x" Nothing Nothing Managed] + result <- compilePlan baseDir modul (Map.fromList [("name", VText "other")]) + result + `shouldBe` Left ["step destination .seihou/other/x is outside this module's state directory; a module may write under .seihou/ only inside .seihou/demo/"] + + it "rejects a rendered destination in Seihou's own state" $ do + withFixture [("helper.txt.tpl", "content")] $ \baseDir -> do + let modul = stateModule [Step Copy "helper.txt.tpl" ".seihou/{{name}}" Nothing Nothing Managed] + result <- compilePlan baseDir modul (Map.fromList [("name", VText "manifest.json")]) + result `shouldBe` Left ["step destination path targets Seihou's own state at .seihou/manifest.json"] + it "allows dots inside a rendered destination filename" $ do withFixture [("README.md.tpl", "content")] $ \baseDir -> do let modul = @@ -1001,3 +1021,20 @@ length errs `shouldSatisfy` (>= 1) T.isInfixOf "missing" (errs !! 0) `shouldBe` True Right _ -> expectationFailure "Expected Left" + +-- | A module named @demo@ with the given steps and no variables. +stateModule :: [Step] -> Module +stateModule steps = + Module + { name = "demo", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = steps, + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } diff --git a/test/Seihou/Engine/ReconcileSpec.hs b/test/Seihou/Engine/ReconcileSpec.hs --- a/test/Seihou/Engine/ReconcileSpec.hs +++ b/test/Seihou/Engine/ReconcileSpec.hs @@ -1,6 +1,7 @@ module Seihou.Engine.ReconcileSpec (tests) where import Control.Lens ((^.)) +import Control.Monad (forM_) import Data.Functor.Identity (Identity (..)) import Data.Generics.Labels () import Data.Map.Strict qualified as Map @@ -22,6 +23,14 @@ spec :: Spec spec = do + describe "exact reconciliation drift" $ do + it "names changed observations and output even when summary counts are equal" $ do + let desired = DesiredFile "README.md" "new" "owner" Template Set.empty False + state = PlannedFileState "new" "new" (hashContent "new") True + planned = ReconciliationPlan Set.empty (Map.singleton "README.md" (FileUpdate desired state (ObservedFile True (Just (hashContent "old"))) Nothing)) Set.empty + actual = ReconciliationPlan Set.empty (Map.singleton "README.md" (FileUpdate desired (PlannedFileState "new" "new with user edit" (hashContent "new with user edit") True) (ObservedFile True (Just (hashContent "old with user edit"))) Nothing)) Set.empty + reconciliationSummary planned `shouldBe` reconciliationSummary actual + reconciliationDifferences planned actual `shouldBe` Map.singleton "README.md" ["observed content", "planned output"] describe "materialization" $ do it "folds four ordered patches into one desired file" $ do let operations = @@ -246,6 +255,43 @@ cleanMerge result `shouldSatisfy` isInvalidPath + it "rejects Seihou's own state, the .seihou directory as a file, and Git data" $ + forM_ [".seihou/baselines/x", ".SEIHOU/manifest.json", ".seihou", ".git/config"] $ \path -> + planWith Map.empty Map.empty Map.empty empty [appA] [WriteFileOp path "bad" Template] (owners path [appA]) cleanMerge + `shouldSatisfy` isInvalidPath + + it "rejects a directory operand inside Seihou's own state" $ + planWith Map.empty Map.empty Map.empty empty [appA] [CreateDirOp ".seihou/baselines"] Map.empty cleanMerge + `shouldSatisfy` isInvalidPath + + it "plans a write into a module's own .seihou directory with its parent directories" $ do + let path = ".seihou/demo/helper.txt" + operations = [CreateDirOp ".seihou", CreateDirOp ".seihou/demo", WriteFileOp path "top\nmiddle v1\nbottom\n" Template] + case planWith Map.empty Map.empty Map.empty empty [appA] operations (owners path [appA]) cleanMerge of + Right reconciliation -> Map.member path (reconciliation ^. #files) `shouldBe` True + Left err -> expectationFailure (show err) + + it "merges a user edit in a module's own .seihou directory like any managed file" $ do + let path = ".seihou/demo/helper.txt" + base = "top\nmiddle v1\nbottom\n" + ref = baselineRefForContent base + manifest = withFile path (record base (Just ref) [appA]) empty + result = + planWith + (Map.singleton path "top edited by user\nmiddle v1\nbottom\n") + Map.empty + (Map.singleton ref base) + manifest + [appA] + [CreateDirOp ".seihou", CreateDirOp ".seihou/demo", WriteFileOp path "top\nmiddle v2\nbottom\n" Template] + (owners path [appA]) + (\_ _ _ -> MergeClean "top edited by user\nmiddle v2\nbottom\n") + case result of + Right reconciliation -> case (reconciliation ^. #files) Map.! path of + FileAutoMerge _ state _ _ -> (state ^. #appliedContent) `shouldBe` "top edited by user\nmiddle v2\nbottom\n" + other -> expectationFailure ("expected automatic merge, got " <> show other) + Left err -> expectationFailure (show err) + describe "classification and resolution" $ do it "preserves a user-only edit without advancing its applied hash" $ do let base = "base\n" @@ -369,7 +415,8 @@ blueprint = manifest ^. #blueprint, seeds = manifest ^. #seeds, checkoutOutputs = manifest ^. #checkoutOutputs, - blueprintMigrations = manifest ^. #blueprintMigrations + blueprintMigrations = manifest ^. #blueprintMigrations, + judgements = manifest ^. #judgements } record :: Text -> Maybe BaselineRef -> [ApplicationId] -> FileRecord diff --git a/test/Seihou/Engine/RemoveSpec.hs b/test/Seihou/Engine/RemoveSpec.hs --- a/test/Seihou/Engine/RemoveSpec.hs +++ b/test/Seihou/Engine/RemoveSpec.hs @@ -248,7 +248,8 @@ blueprint = base ^. #blueprint, seeds = base ^. #seeds, checkoutOutputs = base ^. #checkoutOutputs, - blueprintMigrations = base ^. #blueprintMigrations + blueprintMigrations = base ^. #blueprintMigrations, + judgements = base ^. #judgements } fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "mine.txt"]} @@ -337,6 +338,20 @@ ) Map.member "../outside" (fs ^. #files) `shouldBe` True + it "rejects a removal step destination in Seihou's own state" $ do + let removal = Removal [RemovalStep RemoveFileAction ".seihou/baselines/x" Nothing Nothing] [] + manifest = mkManifestWithRemoval removal [] + fs = mkFS [(".seihou/baselines/x", "keep")] + result = runBuildOps fs manifest modName removal + result + `shouldBe` Left + ( RemovalUnsafePath + "remove-file destination" + ".seihou/baselines/x" + "path targets Seihou's own state at .seihou/baselines" + ) + Map.member ".seihou/baselines/x" (fs ^. #files) `shouldBe` True + it "rejects a removal command workDir with a parent directory segment" $ do let removal = Removal [] [Command "echo unsafe" (Just "../outside") Nothing ApplicationCommand] manifest = mkManifestWithRemoval removal [] @@ -433,7 +448,8 @@ blueprint = base ^. #blueprint, seeds = base ^. #seeds, checkoutOutputs = base ^. #checkoutOutputs, - blueprintMigrations = base ^. #blueprintMigrations + blueprintMigrations = base ^. #blueprintMigrations, + judgements = base ^. #judgements } fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] plan = ExecutedRemovalPlan modName [DeleteFileOp "mine.txt" RFSafe] diff --git a/test/Seihou/Engine/UpdateTransactionSpec.hs b/test/Seihou/Engine/UpdateTransactionSpec.hs --- a/test/Seihou/Engine/UpdateTransactionSpec.hs +++ b/test/Seihou/Engine/UpdateTransactionSpec.hs @@ -302,6 +302,57 @@ readProject projectRoot "file.txt" `shouldReturn` "user\n" Directory.doesDirectoryExist (transaction ^. #transactionDirectory) `shouldReturn` False + describe "module state under .seihou" $ do + it "merges and commits a file in a module's own .seihou directory" $ + withSystemTempDirectory "seihou-update-module-state" $ \projectRoot -> do + let path = ".seihou/demo/helper.txt" + base = "top\nmiddle v1\nbottom\n" + userEdit = "top edited by user\nmiddle v1\nbottom\n" + generated = "top\nmiddle v2\nbottom\n" + merged = "top edited by user\nmiddle v2\nbottom\n" + oldRecord = fileRecord base (Just (baselineRefForContent base)) [appA] + manifest = manifestWithFiles (Map.singleton path oldRecord) + desired = desiredFile path generated [appA] + plan = + ReconciliationPlan + (Set.singleton appA) + (Map.singleton path (FileAutoMerge desired (plannedState generated merged True) (observed userEdit) (Just oldRecord))) + (Set.fromList [".seihou", ".seihou/demo"]) + writeProject projectRoot path userEdit + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton path) + candidate <- expectRight =<< applyReconciliation transaction plan manifest + readProject projectRoot path `shouldReturn` merged + (((candidate ^. #files) Map.! path) ^. #hash) `shouldBe` hashContent merged + completeUpdateTransaction transaction `shouldReturn` Right () + readProject projectRoot path `shouldReturn` merged + + it "refuses Seihou's own state as a transaction target" $ + withSystemTempDirectory "seihou-update-control-target" $ \projectRoot -> do + result <- beginUpdateTransaction projectRoot (Set.singleton ".seihou/manifest.json") + case result of + Left (InvalidTransactionPath path reason) -> do + path `shouldBe` ".seihou/manifest.json" + reason `shouldBe` "path targets Seihou's own state at .seihou/manifest.json" + Left other -> expectationFailure ("expected an invalid path, got " <> show other) + Right _ -> expectationFailure "expected .seihou/manifest.json to be refused" + Directory.doesDirectoryExist (projectRoot ".seihou" "transactions") `shouldReturn` False + + it "refuses a required directory inside Seihou's own state before writing" $ + withSystemTempDirectory "seihou-update-control-directory" $ \projectRoot -> do + writeProject projectRoot "file.txt" "old\n" + let desired = desiredFile "file.txt" "new\n" [appA] + plan = + ReconciliationPlan + (Set.singleton appA) + (Map.singleton "file.txt" (FileUpdate desired (plannedState "new\n" "new\n" True) (observed "old\n") Nothing)) + (Set.singleton ".seihou/baselines") + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + result <- applyReconciliation transaction plan (manifestWithFiles Map.empty) + case result of + Left (InvalidTransactionPath ".seihou/baselines" _) -> pure () + other -> expectationFailure ("expected .seihou/baselines to be refused, got " <> show other) + readProject projectRoot "file.txt" `shouldReturn` "old\n" + describe "partial update of a co-owned path" $ do -- A targeted update plans only the applications it selected, so for a -- co-owned path the reconciliation result describes a subset of the @@ -471,7 +522,8 @@ blueprint = candidate ^. #blueprint, seeds = candidate ^. #seeds, checkoutOutputs = candidate ^. #checkoutOutputs, - blueprintMigrations = candidate ^. #blueprintMigrations + blueprintMigrations = candidate ^. #blueprintMigrations, + judgements = candidate ^. #judgements } setUpdateTransactionExpectedManifest transaction finalManifest `shouldReturn` Right () Directory.createDirectoryIfMissing True (projectRoot ".seihou") @@ -693,7 +745,8 @@ blueprint = manifest ^. #blueprint, seeds = manifest ^. #seeds, checkoutOutputs = manifest ^. #checkoutOutputs, - blueprintMigrations = manifest ^. #blueprintMigrations + blueprintMigrations = manifest ^. #blueprintMigrations, + judgements = manifest ^. #judgements } fileRecord :: Text -> Maybe BaselineRef -> [ApplicationId] -> FileRecord diff --git a/test/Seihou/Engine/ValidateSpec.hs b/test/Seihou/Engine/ValidateSpec.hs --- a/test/Seihou/Engine/ValidateSpec.hs +++ b/test/Seihou/Engine/ValidateSpec.hs @@ -140,6 +140,28 @@ report <- buildReport False tmpDir badModule hasFailedCheck "Safe step destinations" (report ^. #checks) `shouldBe` True + it "reports a destination outside the module's own .seihou directory" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let legacy = + goodModule + & #name .~ "gcp-kube-env" + & #steps .~ [Step Template "README.md.tpl" ".seihou/gcp-kube-env.conf" Nothing Nothing Managed] + report <- buildReport False tmpDir legacy + reportHasErrors report `shouldBe` True + [c ^. #details | c <- report ^. #checks, c ^. #label == "Module state destinations"] + `shouldBe` [["step destination .seihou/gcp-kube-env.conf is outside this module's state directory; a module may write under .seihou/ only inside .seihou/gcp-kube-env/"]] + + it "passes the module state check for the module's own .seihou directory" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let good = goodModule & #steps .~ [Step Template "README.md.tpl" ".seihou/test-module/helper.txt" Nothing Nothing Managed] + report <- buildReport False tmpDir good + hasPassedCheck "Module state destinations" (report ^. #checks) `shouldBe` True + reportHasErrors report `shouldBe` False + it "detects missing module version" $ do withSystemTempDirectory "seihou-validate" $ \tmpDir -> do report <- buildReport False tmpDir badModule diff --git a/test/Seihou/Integration/ExecutionSpec.hs b/test/Seihou/Integration/ExecutionSpec.hs --- a/test/Seihou/Integration/ExecutionSpec.hs +++ b/test/Seihou/Integration/ExecutionSpec.hs @@ -70,7 +70,8 @@ blueprint = base ^. #blueprint, seeds = base ^. #seeds, checkoutOutputs = base ^. #checkoutOutputs, - blueprintMigrations = base ^. #blueprintMigrations + blueprintMigrations = base ^. #blueprintMigrations, + judgements = base ^. #judgements } -- | Extract planned files from operations for computeDiff. diff --git a/test/Seihou/Manifest/TypesSpec.hs b/test/Seihou/Manifest/TypesSpec.hs --- a/test/Seihou/Manifest/TypesSpec.hs +++ b/test/Seihou/Manifest/TypesSpec.hs @@ -50,7 +50,7 @@ -- | Helper to set modules on a Manifest without ambiguous record update. withManifestModules :: [AppliedModule] -> Manifest -> Manifest withManifestModules mods m = - Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #seeds) (m ^. #checkoutOutputs) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations) + Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #seeds) (m ^. #checkoutOutputs) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations) (m ^. #judgements) -- | Every string that appears anywhere inside a value keyed @origin@ or -- @targetOrigin@, at any depth. @@ -445,7 +445,8 @@ blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, - blueprintMigrations = [] + blueprintMigrations = [], + judgements = [] } manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -485,7 +486,8 @@ blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, - blueprintMigrations = [] + blueprintMigrations = [], + judgements = [] } manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -744,6 +746,22 @@ manifest2 `shouldBe` False + -- A receipt recorded while the blueprint was installed over SSH is the + -- same edge once it is installed over HTTPS, and the other way round: + -- completed work stays done and no second receipt is appended. + it "treats equivalent public GitHub transports as one receipt identity, both ways" $ do + let ssh = RemoteOrigin "git@github.com:acme/payments.git" "payments" Nothing + https = RemoteOrigin "https://github.com/acme/payments.git" "payments" Nothing + edgeFrom origin at = AppliedBlueprintMigration (ModuleName "payments") origin (Just "0.5.0") "1.0.0" "2.0.0" MigrationApplied at Nothing + forM_ [(ssh, https), (https, ssh)] $ \(recorded, installed) -> do + let original = edgeFrom recorded fixedTime + manifest1 = writeAppliedBlueprintMigration original (emptyManifest fixedTime) + rerun = edgeFrom installed fixedTime2 + hasAppliedBlueprintMigration installed "payments" "1.0.0" "2.0.0" manifest1 `shouldBe` True + (writeAppliedBlueprintMigration rerun manifest1 ^. #blueprintMigrations) `shouldBe` [rerun] + hasAppliedBlueprintMigration (RemoteOrigin "git@github.com:other/payments.git" "payments" Nothing) "payments" "1.0.0" "2.0.0" manifest1 `shouldBe` False + hasAppliedBlueprintMigration (RemoteOrigin "https://github.com/acme/payments.git" "billing" Nothing) "payments" "1.0.0" "2.0.0" manifest1 `shouldBe` False + -- The upsert key deliberately ignores the outcome, so a re-run replaces -- the earlier record. The read side does not ignore it: an edge that -- reported itself inapplicable has not been applied. @@ -926,7 +944,7 @@ describe "version checking" $ do it "rejects manifests with version higher than current" $ do let base = emptyManifest fixedTime - m = Manifest {version = ManifestSchemaVersion 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, blueprintMigrations = []} + m = Manifest {version = ManifestSchemaVersion 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, blueprintMigrations = [], judgements = []} result = manifestFromJSON (manifestToJSON m) case result of Left err -> err `shouldContain` "newer version" diff --git a/test/Seihou/Manifest/UpgradeSpec.hs b/test/Seihou/Manifest/UpgradeSpec.hs --- a/test/Seihou/Manifest/UpgradeSpec.hs +++ b/test/Seihou/Manifest/UpgradeSpec.hs @@ -63,6 +63,12 @@ spec :: Spec spec = do + it "adds an empty judgement list at schema 15 and refuses a forged one" $ do + let document = Aeson.object ["version" Aeson..= (14 :: Int), "producerField" Aeson..= True] + expected = Aeson.object ["version" Aeson..= (15 :: Int), "producerField" Aeson..= True, "judgements" Aeson..= ([] :: [Aeson.Value])] + fmap snd (upgradeDocumentLosslessly (v 15) document) `shouldBe` Right expected + let forged = Aeson.object ["version" Aeson..= (14 :: Int), "judgements" Aeson..= [Aeson.object []]] + upgradeDocumentLosslessly (v 15) forged `shouldSatisfy` either (const True) (const False) it "upgrades unconditional schema-13 removal without changing producer fields" $ do let document = Aeson.object ["version" Aeson..= (13 :: Int), "producerField" Aeson..= True, "modules" Aeson..= [Aeson.object ["removal" Aeson..= Aeson.object ["steps" Aeson..= [Aeson.object ["action" Aeson..= ("remove-file" :: String), "dest" Aeson..= ("package.json" :: String)]]]]]] case upgradeDocumentLosslessly (v 14) document of