baikai-0.6.0.0: test/EvidenceSpec.hs
{-# LANGUAGE OverloadedRecordDot #-}
-- | Tests for "Baikai.Evidence": that the canonical encoding really is
-- canonical, that the two digests differ in exactly the way they are
-- documented to, and that the configuration projection lets no content
-- through.
module EvidenceSpec (tests) where
import Baikai.Cost (Cost (..), zeroCost)
import Baikai.Evidence
import Baikai.Provider.Cli.Internal qualified as Internal
import Baikai.ThinkingLevel (ThinkingLevel (..))
import Baikai.Usage (Usage (..), zeroUsage)
import Control.Concurrent (threadDelay)
import Control.Monad (replicateM)
import Data.Aeson (Value (Number, Object, String), object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Char8 qualified as BS8
import Data.Set qualified as Set
import Data.Text qualified as Text
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))
tests :: TestTree
tests =
testGroup
"Evidence"
[ canonicalTests,
digestTests,
usageEnvelopeTests,
deriveStrengthTests,
redactionTests,
observedTests,
adjustmentJsonTests,
callIdTests
]
-- ============================================================
-- Adjustment JSON
-- ============================================================
-- | Every adjustment kind, through JSON and back.
--
-- The two sampling kinds carry a @fields@ array and no @requested@
-- level, so a decoder that reads @requested@ before it reads @kind@
-- fails on them. Round-tripping every constructor is what keeps that
-- ordering honest as constructors are added.
adjustmentJsonTests :: TestTree
adjustmentJsonTests =
testGroup
"ThinkingAdjustment JSON"
( [ testCase (show adjustment) (roundTripAdjustment adjustment)
| adjustment <-
[ EffortClamped ThinkingMax "high",
EffortCollapsedToToggle ThinkingHigh,
EffortOmitted ThinkingHigh,
ThinkingDroppedUnsupportedModel ThinkingLow,
ThinkingDroppedUnsupportedHost ThinkingMinimal,
ThinkingDroppedBudgetExceeded ThinkingMax 32000 8192,
SamplingDroppedUnsupportedModel ["temperature", "top_p"],
SamplingDroppedUnsupportedApi ["seed", "frequency_penalty", "presence_penalty"]
]
]
<> [ testCase "a sampling drop encodes its kind and fields and no requested level" $
Aeson.toJSON (SamplingDroppedUnsupportedModel ["temperature", "top_p"])
@?= Aeson.object
[ "kind" Aeson..= ("sampling_dropped_unsupported_model" :: Text.Text),
"fields" Aeson..= (["temperature", "top_p"] :: [Text.Text])
],
testCase "an API-level sampling drop names its own kind" $
Aeson.toJSON (SamplingDroppedUnsupportedApi ["seed"])
@?= Aeson.object
[ "kind" Aeson..= ("sampling_dropped_unsupported_api" :: Text.Text),
"fields" Aeson..= (["seed"] :: [Text.Text])
]
]
)
where
roundTripAdjustment :: ThinkingAdjustment -> IO ()
roundTripAdjustment v = case Aeson.fromJSON (Aeson.toJSON v) of
Aeson.Success v' -> v' @?= v
Aeson.Error e -> assertFailure ("round trip failed: " <> e)
-- ============================================================
-- Canonical encoding
-- ============================================================
-- | The same logical object built by inserting keys in two different
-- orders. Built by folding inserts over two differently ordered lists
-- rather than with 'object', because aeson's 'KeyMap' may or may not
-- preserve insertion order depending on its size and build flags, and
-- the test must be meaningful either way.
canonicalTests :: TestTree
canonicalTests =
testGroup
"canonical encoding"
[ testCase "is stable across map insertion order" $ do
let values = map (Number . fromIntegral) [1 :: Int ..]
keys = ["zulu", "alpha", "mike", "bravo", "yankee", "charlie"]
pairs = zip keys values
forwards = fromPairs pairs
backwards = fromPairs (reverse pairs)
canonicalEncode forwards @?= canonicalEncode backwards
commitmentDigest forwards @?= commitmentDigest backwards,
testCase "sorts keys ascending and emits no whitespace" $ do
let v = fromPairs [("b", Number 2), ("a", Number 1)]
canonicalEncode v @?= BS8.pack "{\"a\":1,\"b\":2}",
testCase "nested objects are sorted too" $ do
let inner = fromPairs [("z", Number 1), ("y", Number 2)]
v = fromPairs [("outer", inner)]
canonicalEncode v @?= BS8.pack "{\"outer\":{\"y\":2,\"z\":1}}",
testCase "array order is preserved" $
canonicalEncode (Aeson.toJSON [3 :: Int, 1, 2])
@?= BS8.pack "[3,1,2]",
testCase "normalises integral and fractional number spellings" $ do
-- Every spelling on the left is the same mathematical value as
-- the one it is compared against; aeson parses them into
-- different Scientific values.
encodeJson "1" @?= "1"
encodeJson "1.0" @?= "1"
encodeJson "1.00" @?= "1"
encodeJson "1e0" @?= "1"
encodeJson "1e2" @?= "100"
encodeJson "0.1" @?= "0.1"
encodeJson "1e-1" @?= "0.1"
encodeJson "1.100" @?= "1.1"
encodeJson "-0.50" @?= "-0.5",
testCase "escapes only what JSON requires" $ do
canonicalEncode (String "a\"b\\c") @?= BS8.pack "\"a\\\"b\\\\c\""
canonicalEncode (String "line\nbreak") @?= BS8.pack "\"line\\nbreak\""
canonicalEncode (String "bell\a") @?= BS8.pack "\"bell\\u0007\""
-- Non-ASCII travels as UTF-8, not as a \u escape.
canonicalEncode (String "\28450\23383")
@?= BS8.pack "\"\230\188\162\229\173\151\""
]
where
encodeJson :: String -> String
encodeJson src = case Aeson.decodeStrict (BS8.pack src) of
Just (v :: Value) -> BS8.unpack (canonicalEncode v)
Nothing -> "<unparsed: " <> src <> ">"
-- | Build an object by folding inserts in the given order, so that a
-- caller can control insertion history. 'Data.Aeson.object' would not
-- do: the point of the ordering test is that two different insertion
-- histories still encode identically.
fromPairs :: [(Text.Text, Value)] -> Value
fromPairs = Object . foldl' step KeyMap.empty
where
step acc (k, v) = KeyMap.insert (Key.fromText k) v acc
-- ============================================================
-- The two digests
-- ============================================================
digestTests :: TestTree
digestTests =
testGroup
"digests"
[ testCase "a digest is sha256: plus 64 lowercase hex characters" $ do
env <- loadFixture
let d = commitmentDigest env
assertBool ("expected a sha256: prefix, got " <> Text.unpack d) $
"sha256:" `Text.isPrefixOf` d
Text.length (Text.drop 7 d) @?= 64
assertBool
("digest must be lowercase hex: " <> Text.unpack d)
(Text.all (`elem` ("0123456789abcdef" :: String)) (Text.drop 7 d)),
-- The golden values below pin the canonicalisation rule. If one
-- of these fails and the fixture has not changed, the encoding
-- changed, and every digest recorded by an earlier build has
-- become unverifiable. That is a major bump of
-- evidenceSchemaVersion, not a value to paste over.
--
-- Both values changed at schema version 2.0, because the fixture
-- gained an `output_config` and a `response_format` and the
-- projection now summarises both. They were recomputed only after
-- the redaction group above was green: a golden value pasted while
-- a marker still leaked would pin the leak.
testCase "the request commitment matches the golden value" $ do
env <- loadFixture
commitmentDigest env
@?= "sha256:7328ef9e177fbf71793c2167c25749b98845ecc5ea1cf9cd5a38ef3aa52d3b0b",
testCase "the configuration digest matches the golden value" $ do
env <- loadFixture
configurationDigest env
@?= "sha256:5ed62ecd1a00798c06de88363e9f6a591610449f1e06fa8bd8260ee7934ea366",
testCase "the configuration digest ignores content, the commitment does not" $ do
let ask subject =
object
[ "model" .= ("m" :: Text.Text),
"messages"
.= [ object
[ "role" .= ("user" :: Text.Text),
"content" .= (subject :: Text.Text)
]
]
]
-- Same length on purpose: the projection keeps a character
-- count, so differing lengths would change the digest for
-- a reason unrelated to content.
q1 = ask "hello"
q2 = ask "world"
configurationDigest q1 @?= configurationDigest q2
assertBool
"the commitment digest must distinguish different content"
(commitmentDigest q1 /= commitmentDigest q2),
testCase "the configuration digest still separates different configurations" $ do
let withModel m = object ["model" .= (m :: Text.Text)]
assertBool
"different models must produce different configuration digests"
(configurationDigest (withModel "a") /= configurationDigest (withModel "b")),
testCase "a non-object envelope projects to null" $
configurationProjection (String "not an envelope") @?= Aeson.Null
]
-- ============================================================
-- The one strength rule
-- ============================================================
-- | All eight combinations, one named case per row.
--
-- Three copies of this rule had drifted: the subprocess one counted a
-- session or thread id as correlation while the two API ones looked only
-- at a captured header, so a host reporting @model@ and @id@ on every
-- chunk but no header landed below a host that sent only a header.
deriveStrengthTests :: TestTree
deriveStrengthTests =
testGroup
"deriveStrength"
[ row "nothing observed" Unobserved Unobserved Unobserved EvidenceRequestedOnly,
row "a model alone does not climb the scale" (Observed "m") Unobserved Unobserved EvidenceRequestedOnly,
row "a request id alone is correlation" Unobserved (Observed "req") Unobserved EvidenceCorrelated,
row "A RESPONSE ID ALONE IS ALSO CORRELATION" Unobserved Unobserved (Observed "resp") EvidenceCorrelated,
row "both identifiers are still correlation" Unobserved (Observed "req") (Observed "resp") EvidenceCorrelated,
row "a model with a request id is model_observed" (Observed "m") (Observed "req") Unobserved EvidenceModelObserved,
row "A MODEL WITH A RESPONSE ID IS ALSO model_observed" (Observed "m") Unobserved (Observed "resp") EvidenceModelObserved,
row "a model with both identifiers is model_observed" (Observed "m") (Observed "req") (Observed "resp") EvidenceModelObserved,
testCase "nothing reaches fully_observed" $
assertBool
"no combination of these three observations may reach the top of the scale"
( all
(< EvidenceFullyObserved)
[ deriveStrength o r i
| o <- both,
r <- both,
i <- both
]
)
]
where
row name observedModel requestId responseId expected =
testCase name (deriveStrength observedModel requestId responseId @?= expected)
both = [Unobserved, Observed "x"]
-- ============================================================
-- The usage a response digest commits to
-- ============================================================
usageEnvelopeTests :: TestTree
usageEnvelopeTests =
testGroup
"usage envelope"
[ testCase "two usages differing only in cost produce the same envelope" $ do
-- The cost is computed here from the caller's catalog rates, not
-- read off the response, so a verifier holding only the response
-- could not recompute a digest that covered it — and the digest
-- changed whenever a price was edited.
let cheap = zeroUsage {inputTokens = 10, outputTokens = 20}
dear = cheap {cost = zeroCost {usd = 1234}}
usageEnvelope cheap @?= usageEnvelope dear,
testCase "the encoded envelope carries no cost key" $ do
let encoded = BS8.unpack (canonicalEncode (usageEnvelope zeroUsage))
assertBool
("cost survived into the usage envelope: " <> encoded)
(not ("cost" `isInfix` encoded))
mapM_
( \k ->
assertBool
(k <> " missing from the usage envelope: " <> encoded)
(k `isInfix` encoded)
)
[ "input_tokens",
"output_tokens",
"cache_read_tokens",
"cache_write_tokens",
"reasoning_tokens",
"total_tokens"
]
]
where
isInfix needle haystack =
Text.isInfixOf (Text.pack needle) (Text.pack haystack)
-- ============================================================
-- Redaction
-- ============================================================
-- | The four markers below are the API key, the prompt body, the
-- reasoning text, and a tool-call argument payload planted in the
-- fixture. The assertion is on the encoded bytes rather than on the
-- projected structure, because the claim being tested is that none of
-- them survives into the output no matter how it got there.
redactionTests :: TestTree
redactionTests =
testGroup
"redaction"
[ testCase "the configuration projection drops all content" $ do
env <- loadFixture
let encoded = BS8.unpack (canonicalEncode (configurationProjection env))
mapM_
( \marker ->
assertBool
(marker <> " survived into the configuration projection: " <> encoded)
(not (marker `isInfix` encoded))
)
[ "sk-baikai-fixture-secret-key",
"PROMPT-BODY-MARKER",
"SYSTEM-PROMPT-BODY-MARKER",
"REASONING-TEXT-MARKER",
"TOOL-PAYLOAD-MARKER",
"Fetch a quarterly report by identifier.",
-- A JSON schema is content wherever it appears. These two
-- markers sit in the `description` of a structured-output
-- schema reached two different ways: Anthropic's
-- `output_config.format.schema` and the OpenAI-compatible
-- `response_format.json_schema.schema`. The fixture is one
-- recorded envelope serving both the digest and the
-- redaction tests, and it already carries a non-wire
-- `extra_headers` key, so mixing an OpenAI-shaped key into
-- an Anthropic-shaped body is in keeping.
"OUTPUT-SCHEMA-MARKER",
"RESPONSE-SCHEMA-MARKER"
],
testCase "the projection keeps the configuration it is supposed to" $ do
env <- loadFixture
let encoded = BS8.unpack (canonicalEncode (configurationProjection env))
mapM_
( \kept ->
assertBool
(kept <> " should have been kept, but was not: " <> encoded)
(kept `isInfix` encoded)
)
[ "claude-opus-4-6",
"budget_tokens",
"max_tokens",
"temperature",
-- A tool's name is configuration; its description is not.
"fetch_report",
-- The same rule around a structured-output schema: the
-- effort, the schema's name and its strictness are how the
-- call is configured.
"effort",
"quarterly_report",
"strict"
],
testCase "the commitment digest does see the content" $ do
env <- loadFixture
let encoded = BS8.unpack (canonicalEncode env)
assertBool
"the commitment input must contain the prompt body"
("PROMPT-BODY-MARKER" `isInfix` encoded),
-- The subprocess providers pass their rendered argument vector as
-- the request envelope, and both of them place the prompt inside
-- it. The commitment digest therefore covers the prompt, which is
-- correct; the configuration projection must not.
--
-- It does not, for a structural reason worth stating: the
-- projection admits named fields from an object, and a JSON array
-- has none, so an argv envelope projects to @null@ wholesale. That
-- is the allow-list failing in the safe direction.
testCase "an argv envelope's configuration projection keeps nothing" $ do
let argv = Internal.argvEnvelope "codex" ["exec", "--model", "gpt-5.6", "--", "PROMPT-BODY-MARKER"]
projected = BS8.unpack (canonicalEncode (configurationProjection argv))
committed = BS8.unpack (canonicalEncode argv)
projected @?= "null"
assertBool
"the commitment input must contain the argv prompt"
("PROMPT-BODY-MARKER" `isInfix` committed)
assertBool
"the configuration projection must not contain the argv prompt"
(not ("PROMPT-BODY-MARKER" `isInfix` projected))
]
where
isInfix needle haystack =
Text.isInfixOf (Text.pack needle) (Text.pack haystack)
-- ============================================================
-- Observed
-- ============================================================
observedTests :: TestTree
observedTests =
testGroup
"observed"
[ testCase "encodes Unobserved as the string \"unobserved\"" $
Aeson.toJSON (Unobserved :: Observed Text.Text) @?= String "unobserved",
testCase "encodes an observed value under an observed key" $
Aeson.toJSON (Observed ("claude-opus-4-6" :: Text.Text))
@?= object ["observed" .= ("claude-opus-4-6" :: Text.Text)],
testCase "round-trips through JSON in both directions" $ do
roundTrip (Observed ("m" :: Text.Text))
roundTrip (Unobserved :: Observed Text.Text),
testCase "observedValue reports absence rather than defaulting" $ do
observedValue (Observed ("m" :: Text.Text)) @?= Just "m"
observedValue (Unobserved :: Observed Text.Text) @?= Nothing,
-- Strict evidence mode compares a record's strength against the
-- caller's requirement with (>=), so this ordering is load-bearing
-- rather than cosmetic.
testCase "evidence strength ascends in the order strict mode compares" $ do
let ascending =
[ EvidenceRequestedOnly,
EvidenceCorrelated,
EvidenceModelObserved,
EvidenceFullyObserved
]
assertBool
"EvidenceStrength constructors must ascend as declared"
(and (zipWith (<) ascending (drop 1 ascending))),
testCase "noThinkingRequested records absence, not an unsupported level" $ do
requested noThinkingRequested @?= Nothing
mode noThinkingRequested @?= ThinkingModeAbsent
adjustments noThinkingRequested @?= [],
-- Destructured rather than accessed by selector: 'runId',
-- 'attempt', and 'supersedes' name a field on both
-- 'EvidenceRequest' and 'ModelCallEvidence', and under
-- DuplicateRecordFields a bare selector is ambiguous. Library
-- code reaches these through 'OverloadedRecordDot' or the
-- generic-lens labels (@r ^. #runId@) the rest of this codebase
-- uses; the constructor is no longer exported.
testCase "evidenceRequest defaults to best effort, attempt one" $ do
let req = evidenceRequest "run-42"
req.runId @?= "run-42"
req.strictness @?= EvidenceBestEffort
req.attempt @?= 1
req.supersedes @?= Nothing
]
where
roundTrip :: Observed Text.Text -> IO ()
roundTrip v = case Aeson.fromJSON (Aeson.toJSON v) of
Aeson.Success v' -> v' @?= v
Aeson.Error e -> assertFailure ("round trip failed: " <> e)
-- ============================================================
-- Identifiers
-- ============================================================
callIdTests :: TestTree
callIdTests =
testGroup
"call ids"
[ -- Generated in a tight loop, so most of these share a
-- millisecond. If the counter were dropped from the layout, this
-- would collapse to a handful of distinct values.
testCase "70000 ids generated back to back are all distinct" $ do
ids <- replicateM 70000 newCallId
length (nub' ids) @?= 70000,
testCase "an id is 32 lowercase hex characters" $ do
cid <- newCallId
Text.length cid @?= 32
assertBool
("expected lowercase hex, got " <> Text.unpack cid)
(Text.all (`elem` ("0123456789abcdef" :: String)) cid),
-- The millisecond prefix occupies the high bits, so ids minted
-- later never sort before ids minted earlier.
testCase "ids sort chronologically" $ do
earlier <- newCallId
threadDelay 2000
later <- newCallId
assertBool
(Text.unpack earlier <> " should sort before " <> Text.unpack later)
(earlier < later)
]
where
nub' = Set.toList . Set.fromList
-- ============================================================
-- Fixture loading
-- ============================================================
fixturePath :: FilePath
fixturePath = "test/fixtures/evidence-request.json"
-- | The recorded request envelope both golden tests hash. It carries
-- an API key in a header-shaped field, a prompt body, reasoning text,
-- and a tool-call argument payload, so one fixture serves the digest
-- tests and the redaction tests.
loadFixture :: IO Value
loadFixture = do
raw <- Aeson.eitherDecodeFileStrict' fixturePath
case raw of
Left err -> assertFailure ("could not read " <> fixturePath <> ": " <> err)
Right v -> pure v