seihou-cli-0.16.0.0: test/Seihou/CLI/JudgementCheckSpec.hs
module Seihou.CLI.JudgementCheckSpec (tests) where
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Either (isLeft)
import Data.Foldable (toList)
import Data.Generics.Labels ()
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.IO qualified as TIO
import Data.Time (UTCTime (..), fromGregorian)
import Seihou.CLI.AgentCompletion (AgentProvider (..))
import Seihou.CLI.Judgement.Adopt
import Seihou.CLI.Judgement.Check
import Seihou.CLI.Judgement.CommitGate (CommitBlocked (..), gatedCommitWith, renderBlocked)
import Seihou.CLI.Judgement.Evidence (gitBytes)
import Seihou.CLI.Judgement.Hooks
import Seihou.CLI.Judgement.Runtime (GateRoute (..), JudgementBackend (..), JudgementRoute (..))
import Seihou.CLI.Judgement.Scanner (findScanner)
import Seihou.CLI.Judgement.Validate (validateJudgementDir)
import Seihou.Core.Judgement
import Seihou.Core.JudgementExamples (ExpectedStatus (..))
import Seihou.Core.Types (ActiveJudgement (..), ApplicationId (..), JudgementOwner (..), JudgementSource (..), ManifestSchemaVersion (..))
import Seihou.Dhall.Eval (evalJudgementFromFile)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.ManifestStore (writeManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Manifest.Judgement (definitionDigest)
import Seihou.Manifest.Types (emptyManifest, manifestFromJSON)
import Seihou.Prelude
import System.Directory (createDirectoryIfMissing, doesFileExist, executable, getPermissions)
import System.FilePath (takeDirectory)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (callProcess)
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec (testSpec)
git :: FilePath -> [String] -> IO ()
git dir args = callProcess "git" (["-C", dir, "-c", "user.name=t", "-c", "user.email=t@example.invalid", "-c", "commit.gpgsign=false"] <> args)
writeAt :: FilePath -> FilePath -> Text -> IO ()
writeAt dir p body = do
createDirectoryIfMissing True (takeDirectory (dir </> p))
BS.writeFile (dir </> p) (TE.encodeUtf8 body)
withRepo :: (FilePath -> IO a) -> IO a
withRepo act = withSystemTempDirectory "judgement-check" $ \dir -> do
git dir ["init", "-q"]
git dir ["commit", "-q", "--allow-empty", "-m", "init"]
act dir
-- | A judgement with nothing to do with secrets: two checks with different
-- thresholds, the second asked in the direction where no is the concern.
docsJudgement :: JudgementDefinition
docsJudgement =
JudgementDefinition
{ name = "docs-review",
version = Just "1.0.0",
description = Nothing,
instructions = "Review documentation changes.",
evidence = EvidenceDeclaration [StagedChangesScope] ["docs/**"] [],
limits = defaultCoverageLimits,
deterministicChecks = [],
checks =
JudgementCheck "stale-docs" "Does this change leave documented behaviour out of date?" Yes Nothing Nothing [] Enforced High (Thresholds 0.5 0.1) (Thresholds 0.9 0.05) True
:| [JudgementCheck "has-example" "Does every new command in this change come with an example?" No Nothing Nothing [] Advisory High (Thresholds 0.8 0.4) (Thresholds 0.9 0.05) True]
}
active :: JudgementDefinition -> ActiveJudgement
active def = ActiveJudgement BundledJudgement def (definitionDigest def) (defaultPolicy ApprovedRemote False def) [DirectAdoption]
-- | A backend that answers each check with a fixed probability of yes and
-- counts requests.
stub :: IORef Int -> (Text -> Double) -> JudgementBackend
stub calls yesFor =
JudgementBackend
{ review = \_ c _ -> modifyIORef' calls (+ 1) >> pure (Right (RawReview (concernProbability (c ^. #concernWhen) (yesFor (c ^. #name))) [] False)),
gate = Nothing,
observed = pure []
}
servicesWith :: FilePath -> Maybe JudgementBackend -> IO CheckServices
servicesWith root be = do
sc <- findScanner
pure (CheckServices (gitBytes root) sc (\_ -> pure (Right (BackendChoice be True (Just "stub model") Nothing))))
request :: CheckRequest
request = CheckRequest Nothing Nothing False False
tests :: IO TestTree
tests = testSpec "judgement check, adoption and hooks" $ do
describe "the bundled catalogue" $ do
it "decodes and validates security-review with the secret scan declared" $ do
r <- evalJudgementFromFile "data/judgements/security-review/judgement.dhall"
case r of
Left e -> expectationFailure (show e)
Right d -> do
d ^. #name `shouldBe` "security-review"
d ^. #deterministicChecks `shouldBe` [SecretScan]
validateDefinition d `shouldBe` Right ()
it "ships a valid release corpus of at least 20 benign and 20 unsafe cases" $ do
v <- validateJudgementDir "data/judgements/security-review"
v ^. #errors `shouldBe` []
let cases = maybe [] (^. #examples) (v ^. #examples)
benign = [e | e <- cases, all (== ExpectPassed) (Map.elems (e ^. #expect))]
length benign `shouldSatisfy` (>= 20)
(length cases - length benign) `shouldSatisfy` (>= 20)
describe "seihou check" $ do
it "reports nothing to check when no judgement is active" $ withRepo $ \dir -> do
services <- servicesWith dir Nothing
out <- runCheck services [] request
out ^. #exitCode `shouldBe` 0
out ^. #output `shouldSatisfy` T.isInfixOf "nothing was checked"
it "refuses a named judgement that is not active" $ withRepo $ \dir -> do
services <- servicesWith dir Nothing
out <- runCheck services [active docsJudgement] (request & #judgement ?~ "other")
out ^. #exitCode `shouldBe` 1
out ^. #output `shouldSatisfy` T.isInfixOf "seihou run other"
it "runs a non-security judgement whose two checks reach their own outcomes" $ withRepo $ \dir -> do
writeAt dir "docs/guide.md" "Run `demo sync` to refresh the cache.\n"
writeAt dir "src/Main.hs" "main = pure ()\n"
git dir ["add", "."]
calls <- newIORef 0
services <- servicesWith dir (Just (stub calls (\case "stale-docs" -> 0.3; _ -> 0.5)))
out <- runCheck services [active docsJudgement] request
-- stale-docs: 0.3 sits between pass 0.1 and block 0.5. has-example is
-- advisory with a concern of 1 - 0.5 = 0.5, inside its own band.
out ^. #exitCode `shouldBe` 11
out ^. #output `shouldSatisfy` T.isInfixOf "stale-docs needs review"
out ^. #output `shouldSatisfy` T.isInfixOf "has-example needs review (advisory)"
out ^. #output `shouldSatisfy` T.isInfixOf "one minus the model's probability of yes"
readIORef calls >>= (`shouldBe` 2)
it "passes when every enforced check is at or below its pass threshold, and agrees in JSON" $ withRepo $ \dir -> do
writeAt dir "docs/guide.md" "Run `demo sync` to refresh the cache.\n"
git dir ["add", "."]
calls <- newIORef 0
services <- servicesWith dir (Just (stub calls (\case "stale-docs" -> 0.05; _ -> 0.95)))
out <- runCheck services [active docsJudgement] request
out ^. #exitCode `shouldBe` 0
json <- runCheck services [active docsJudgement] (request & #json .~ True)
json ^. #exitCode `shouldBe` 0
json ^. #output `shouldSatisfy` T.isInfixOf "\"exitCode\":0"
it "makes no model request on a dry run and never claims approval" $ withRepo $ \dir -> do
writeAt dir "docs/guide.md" "Text.\n"
git dir ["add", "."]
calls <- newIORef 0
services <- servicesWith dir (Just (stub calls (const 0.0)))
out <- runCheck services [active docsJudgement] (request & #dryRun .~ True)
out ^. #exitCode `shouldBe` 0
out ^. #output `shouldSatisfy` T.isInfixOf "nothing was approved"
readIORef calls >>= (`shouldBe` 0)
describe "pre-commit hooks" $ do
it "installs an owned hook, then recognises it" $ withRepo $ \dir -> do
Right plan <- planHook dir (gitBytes dir)
plan `shouldBe` HookInstall (dir </> ".git" </> "hooks" </> "pre-commit")
applyHook plan `shouldReturn` Right ()
body <- TIO.readFile (dir </> ".git" </> "hooks" </> "pre-commit")
body `shouldSatisfy` T.isInfixOf hookMarker
executable <$> getPermissions (dir </> ".git" </> "hooks" </> "pre-commit") `shouldReturn` True
planHook dir (gitBytes dir) `shouldReturn` Right (HookAlreadyInstalled (dir </> ".git" </> "hooks" </> "pre-commit"))
it "preserves a user's hook byte for byte and runs it first" $ withRepo $ \dir -> do
let hook = dir </> ".git" </> "hooks" </> "pre-commit"
original = "#!/bin/sh\necho mine\n"
writeAt dir ".git/hooks/pre-commit" original
Right plan <- planHook dir (gitBytes dir)
plan `shouldBe` HookChain hook (hook <> ".seihou-original")
applyHook plan `shouldReturn` Right ()
TIO.readFile (hook <> ".seihou-original") `shouldReturn` original
TIO.readFile hook >>= (`shouldSatisfy` T.isInfixOf "pre-commit.seihou-original")
it "sits beside a pre-commit framework hook without replacing it" $ withRepo $ \dir -> do
let framework = "#!/usr/bin/env bash\n# File generated by pre-commit: https://pre-commit.com\n"
writeAt dir ".git/hooks/pre-commit" framework
Right plan <- planHook dir (gitBytes dir)
plan `shouldBe` HookBesideFramework (dir </> ".git" </> "hooks" </> "pre-commit.legacy")
applyHook plan `shouldReturn` Right ()
TIO.readFile (dir </> ".git" </> "hooks" </> "pre-commit") `shouldReturn` framework
it "refuses a core.hooksPath outside the repository but accepts one inside it" $ withRepo $ \dir -> withSystemTempDirectory "shared-hooks" $ \shared -> do
git dir ["config", "core.hooksPath", shared]
planHook dir (gitBytes dir) >>= (`shouldSatisfy` isLeft)
git dir ["config", "core.hooksPath", ".git/hooks"]
planHook dir (gitBytes dir) >>= (`shouldSatisfy` \case Right (HookInstall _) -> True; _ -> False)
describe "adoption" $ do
let route = Just (JudgementRoute AgentProviderClaudeCli "claude-sonnet-5")
it "names the configuration to set when no route or consent is given" $ withRepo $ \dir -> do
sc <- findScanner
Left noRoute <- planAdoption dir (AdoptionInputs Nothing Nothing sc Nothing) (Just ApprovedRemote) DirectAdoption BundledJudgement docsJudgement
noRoute `shouldSatisfy` T.isInfixOf "seihou config set judgement.provider"
Left noConsent <- planAdoption dir (AdoptionInputs route Nothing sc Nothing) Nothing DirectAdoption BundledJudgement docsJudgement
noConsent `shouldSatisfy` T.isInfixOf "judgement.dataPolicy approved-remote"
doesFileExist (dir </> ".seihou" </> "manifest.json") `shouldReturn` False
it "names a configured gate in the preview and records that the policy permits it" $ withRepo $ \dir -> do
sc <- findScanner
case sc of
Nothing -> pendingWith "gitleaks is not on PATH"
Just _ -> do
Right plain <- planAdoption dir (AdoptionInputs route (Just ApprovedRemote) sc Nothing) (Just ApprovedRemote) DirectAdoption BundledJudgement docsJudgement
plain ^. #active . #policy . #gatePermitted `shouldBe` False
renderAdoptionPlan plain `shouldSatisfy` T.isInfixOf "gate: none"
Right gated <- planAdoption dir (AdoptionInputs route (Just ApprovedRemote) sc (Just (GateRoute "jev-latest"))) (Just ApprovedRemote) DirectAdoption BundledJudgement docsJudgement
gated ^. #active . #policy . #gatePermitted `shouldBe` True
renderAdoptionPlan gated `shouldSatisfy` T.isInfixOf "gate: typesafe jev-latest (judgment-only"
let noGate = docsJudgement & #checks %~ fmap (#useGate .~ False)
Right unused <- planAdoption dir (AdoptionInputs route (Just ApprovedRemote) sc (Just (GateRoute "jev-latest"))) (Just ApprovedRemote) DirectAdoption BundledJudgement noGate
renderAdoptionPlan unused `shouldSatisfy` T.isInfixOf "no check of this judgement uses a gate"
it "ships the bundled security-review with the unqualified gate off" $ do
Right d <- evalJudgementFromFile "data/judgements/security-review/judgement.dhall"
map (^. #useGate) (toList (d ^. #checks)) `shouldBe` [False, False]
it "records the snapshot at schema 15 and installs the hook, idempotently" $ withRepo $ \dir -> do
sc <- findScanner
case sc of
Nothing -> pendingWith "gitleaks is not on PATH"
Just _ -> do
Right plan <- planAdoption dir (AdoptionInputs route (Just ApprovedRemote) sc Nothing) (Just ApprovedRemote) DirectAdoption BundledJudgement docsJudgement
applyAdoption plan `shouldReturn` Right ()
Right m <- manifestFromJSON . LBS.fromStrict <$> BS.readFile (dir </> ".seihou" </> "manifest.json")
m ^. #version `shouldBe` ManifestSchemaVersion 15
map (^. #definition . #name) (m ^. #judgements) `shouldBe` ["docs-review"]
TIO.readFile (dir </> ".git" </> "hooks" </> "pre-commit") >>= (`shouldSatisfy` T.isInfixOf hookMarker)
Right again <- planAdoption dir (AdoptionInputs route (Just ApprovedRemote) sc Nothing) (Just ApprovedRemote) DirectAdoption BundledJudgement docsJudgement
renderAdoptionPlan again `shouldSatisfy` T.isInfixOf "nothing changes"
applyAdoption again `shouldReturn` Right ()
Right m' <- manifestFromJSON . LBS.fromStrict <$> BS.readFile (dir </> ".seihou" </> "manifest.json")
length (m' ^. #judgements) `shouldBe` 1
describe "the commit gate for seihou's own commits" $ do
let withActive defs dir act = do
createDirectoryIfMissing True (dir </> ".seihou")
runEff (runFilesystem (runManifestStore (dir </> ".seihou" </> "manifest.json") (writeManifest (emptyManifest (UTCTime (fromGregorian 2026 11 11) 0) & #judgements .~ map active defs))))
act
recorder = do
messages <- newIORef (0 :: Int)
commits <- newIORef ([] :: [Text])
pure (messages, commits, \m -> modifyIORef' commits (m :) >> pure (Right ()))
it "reviews again when the index changes while the message is produced" $ withRepo $ \dir -> withActive [docsJudgement] dir $ do
writeAt dir "docs/guide.md" "Run `demo sync`.\n"
git dir ["add", "docs/guide.md"]
calls <- newIORef (0 :: Int)
(messages, commits, commit) <- recorder
let services = servicesWith dir (Just (stub calls (\case "has-example" -> 0.98; _ -> 0.02)))
mkMessage = do
modifyIORef' messages (+ 1)
writeAt dir "docs/extra.md" "More.\n"
git dir ["add", "docs/extra.md"]
pure "docs: add guide"
gatedCommitWith services dir mkMessage commit `shouldReturn` Right ()
readIORef messages `shouldReturn` 1
readIORef commits `shouldReturn` ["docs: add guide"]
-- Two checks, reviewed once before and once after the index changed.
readIORef calls `shouldReturn` 4
it "produces no message and makes no commit when a check blocks" $ withRepo $ \dir -> withActive [docsJudgement] dir $ do
writeAt dir "docs/guide.md" "Run `demo sync`.\n"
git dir ["add", "docs/guide.md"]
calls <- newIORef (0 :: Int)
(messages, commits, commit) <- recorder
result <- gatedCommitWith (servicesWith dir (Just (stub calls (const 0.95)))) dir (modifyIORef' messages (+ 1) >> pure "fixed message") commit
case result of
Left (CommitBlocked code report) -> do
code `shouldBe` 10
renderBlocked (CommitBlocked code report) `shouldSatisfy` T.isInfixOf "Changes applied; commit blocked"
other -> expectationFailure ("expected a block, got " <> show other)
readIORef messages `shouldReturn` 0
readIORef commits `shouldReturn` []
it "sends nothing to the reviewer or the message generator when the scanner blocks" $ withRepo $ \dir -> do
sc <- findScanner
case sc of
Nothing -> pendingWith "gitleaks is not on PATH"
Just _ -> withActive [docsJudgement & #deterministicChecks .~ [SecretScan] & #evidence . #include .~ []] dir $ do
-- Assembled at run time so this source holds no credential-shaped literal.
let token = "ghp_" <> T.replicate 4 "Z" <> "1aB2cD3eF4gH5iJ6kL7mN8oP9qR0sT1u"
writeAt dir "config/env.sh" ("export GH_TOKEN=" <> token <> "\n")
git dir ["add", "config/env.sh"]
calls <- newIORef (0 :: Int)
(messages, commits, commit) <- recorder
result <- gatedCommitWith (servicesWith dir (Just (stub calls (const 0.0)))) dir (modifyIORef' messages (+ 1) >> pure "m") commit
case result of
Left (CommitBlocked code report) -> do
code `shouldBe` 10
report `shouldNotSatisfy` T.isInfixOf token
other -> expectationFailure ("expected a block, got " <> show other)
readIORef calls `shouldReturn` 0
readIORef messages `shouldReturn` 0
readIORef commits `shouldReturn` []