seihou-core 0.15.0.0 → 0.16.0.0

raw patch · 44 files changed

+3615/−203 lines, 44 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• seihou-core.cabal +9/−1
• src/Seihou/Composition/RecipeChain.hs +4/−2
• src/Seihou/Composition/Resolve.hs +2/−2
• src/Seihou/Core/ArtifactFiles.hs +53/−0
• src/Seihou/Core/ArtifactIdentity.hs +205/−17
• src/Seihou/Core/Judgement.hs +758/−0
• src/Seihou/Core/JudgementExamples.hs +141/−0
• src/Seihou/Core/JudgementState.hs +104/−0
• src/Seihou/Core/Migration.hs +3/−0
• src/Seihou/Core/Module.hs +110/−11
• src/Seihou/Core/Path.hs +118/−0
• src/Seihou/Core/Registry.hs +104/−31
• src/Seihou/Core/Scaffold.hs +75/−0
• src/Seihou/Core/Types.hs +47/−1
• src/Seihou/Dhall/Eval.hs +169/−12
• src/Seihou/Engine/Migrate.hs +67/−3
• src/Seihou/Engine/Plan.hs +49/−31
• src/Seihou/Engine/Reconcile.hs +66/−15
• src/Seihou/Engine/Remove.hs +14/−3
• src/Seihou/Engine/UpdateTransaction.hs +20/−16
• src/Seihou/Engine/Validate.hs +2/−0
• src/Seihou/Manifest/Judgement.hs +184/−0
• src/Seihou/Manifest/Types.hs +62/−4
• src/Seihou/Manifest/Upgrade.hs +10/−1
• test/Main.hs +7/−1
• test/Seihou/Core/ArtifactIdentitySpec.hs +191/−11
• test/Seihou/Core/JudgementArtifactSpec.hs +194/−0
• test/Seihou/Core/JudgementSpec.hs +332/−0
• test/Seihou/Core/ModuleSpec.hs +39/−0
• test/Seihou/Core/PathSpec.hs +110/−0
• test/Seihou/Core/RegistryEmitSpec.hs +12/−6
• test/Seihou/Core/RegistrySpec.hs +46/−23
• test/Seihou/Core/RegistrySyncSpec.hs +2/−1
• test/Seihou/Dhall/MigrationDecoderSpec.hs +26/−0
• test/Seihou/Engine/DiffSpec.hs +2/−1
• test/Seihou/Engine/MigrateSpec.hs +68/−0
• test/Seihou/Engine/PlanSpec.hs +37/−0
• test/Seihou/Engine/ReconcileSpec.hs +48/−1
• test/Seihou/Engine/RemoveSpec.hs +18/−2
• test/Seihou/Engine/UpdateTransactionSpec.hs +55/−2
• test/Seihou/Engine/ValidateSpec.hs +22/−0
• test/Seihou/Integration/ExecutionSpec.hs +2/−1
• test/Seihou/Manifest/TypesSpec.hs +22/−4
• test/Seihou/Manifest/UpgradeSpec.hs +6/−0

@@ -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

@@ -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]

@@ -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 $

@@ -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"

@@ -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.

@@ -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

@@ -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]

@@ -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

@@ -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) 

@@ -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/<its name>/@.+-- 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]

@@ -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/<area>@, where @<area>@ (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/<its own name>/@, 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.

@@ -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),       "}"     ] 

@@ -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 }]",+      "    }",+      "  ]",+      "}"     ]

@@ -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.

@@ -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)+        )

@@ -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/<name>.conf@ into the+-- module's own @.seihou/<name>/@ 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"))

@@ -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/<its own name>/@ 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"]@.

@@ -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

@@ -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

@@ -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

@@ -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),

@@ -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"

@@ -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)

@@ -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

@@ -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])

@@ -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)+  ]

@@ -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))

@@ -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)

@@ -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")

@@ -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

@@ -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 

@@ -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"),

@@ -162,5 +162,6 @@       modules = mods,       recipes = recs,       blueprints = [],-      prompts = []+      prompts = [],+      judgements = []     }

@@ -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

@@ -59,7 +59,8 @@           blueprint = base ^. #blueprint,           seeds = base ^. #seeds,           checkoutOutputs = base ^. #checkoutOutputs,-          blueprintMigrations = base ^. #blueprintMigrations+          blueprintMigrations = base ^. #blueprintMigrations,+          judgements = base ^. #judgements         }  spec :: Spec

@@ -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 []

@@ -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 = []+    }

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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.

@@ -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"

@@ -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