baikai-claude 0.4.0.1 → 0.5.0.0

raw patch · 13 files changed

+2357/−246 lines, 13 filesdep +stmdep +temporarydep ~baikaidep ~streamlyPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, temporary

Dependency ranges changed: baikai, streamly

API changes (from Hackage documentation)

Files

• baikai-claude.cabal +26/−3
• src/Baikai/Provider/Claude/Agent.hs +202/−0
• src/Baikai/Provider/Claude/Api.hs +348/−71
• src/Baikai/Provider/Claude/Cli.hs +146/−71
• src/Baikai/Provider/Claude/Interactive.hs +64/−26
• src/Baikai/Provider/Claude/Internal/Request.hs +159/−36
• src/Baikai/Provider/Claude/Sse.hs +65/−5
• test/CliEvidenceSpec.hs +397/−0
• test/EvidenceSpec.hs +310/−0
• test/Main.hs +420/−23
• test/ShapeSpec.hs +1/−1
• test/SseSpec.hs +102/−5
• test/ThinkingSpec.hs +117/−5

@@ -1,6 +1,6 @@ cabal-version: 3.4 name:          baikai-claude-version:       0.4.0.1+version:       0.5.0.0 synopsis:      Anthropic Claude providers for the baikai abstraction description:   Wraps the claude Haskell package as a Baikai Provider for both the Anthropic API and the@@ -21,6 +21,21 @@     -fhide-source-paths -Wmissing-export-lists -Wpartial-fields     -Wmissing-deriving-strategies +  -- Exhaustiveness is an error, not a warning. A non-exhaustive match+  -- is a crash the compiler already found: it fails at runtime, on+  -- whichever input reaches the missing branch, usually in front of a+  -- user. This is not hypothetical here — adding a constructor to+  -- AgentRunFailure left `failureExitCode` non-exhaustive and shipped a+  -- pattern-match failure on `baikai agent run --require-evidence`,+  -- because the warning scrolled past in a build log.+  --+  -- Promoted individually rather than through -Werror, which would also+  -- fail the build on warnings that are stylistic or that a future GHC+  -- invents, and would push people toward blanket suppression.+  ghc-options:+    -Werror=incomplete-patterns -Werror=incomplete-uni-patterns+    -Werror=incomplete-record-updates+   default-language:   GHC2024   default-extensions:     DeriveAnyClass@@ -32,6 +47,7 @@   import:          common-options   hs-source-dirs:  src   exposed-modules:+    Baikai.Provider.Claude.Agent     Baikai.Provider.Claude.Api     Baikai.Provider.Claude.Cli     Baikai.Provider.Claude.Interactive@@ -41,9 +57,11 @@     Baikai.Provider.Claude.Sse     Baikai.Provider.Claude.Transport +  other-modules:   Paths_baikai_claude+  autogen-modules: Paths_baikai_claude   build-depends:     , aeson              ^>=2.2-    , baikai             ^>=0.4.0+    , baikai             ^>=0.5.0     , base               >=4.20   && <5     , base64-bytestring  ^>=1.2     , bytestring         ^>=0.12@@ -70,7 +88,9 @@   hs-source-dirs: test   main-is:        Main.hs   other-modules:+    CliEvidenceSpec     ErrorClassSpec+    EvidenceSpec     ShapeSpec     SseSpec     ThinkingSpec@@ -80,7 +100,7 @@   ghc-options:    -threaded -with-rtsopts=-N   build-depends:     , aeson-    , baikai            ^>=0.4.0+    , baikai            ^>=0.5.0     , baikai-claude     , base              >=4.20   && <5     , bytestring@@ -94,9 +114,12 @@     , http-types     , lens              ^>=5.3     , servant-client+    , stm+    , streamly     , streamly-core     >=0.3    && <0.5     , tasty     , tasty-hunit+    , temporary     , text              ^>=2.1     , time     , vector

@@ -0,0 +1,202 @@+-- | Render the argument vector for an __unattended__ Claude Code run+-- from Baikai's provider-neutral unattended request type.+--+-- This module is intentionally separate from the other two Claude+-- surfaces. "Baikai.Provider.Claude.Cli" drives @claude -p@ as a batch+-- completion provider and returns a parsed response.+-- "Baikai.Provider.Claude.Interactive" starts the interactive terminal+-- UI and returns when the human quits. This module describes a run with+-- no terminal and no human, whose deliverable is the changed working+-- tree.+--+-- Every function here is pure: nothing is spawned, and the prompt is+-- carried as data rather than as an argument. A policy Claude Code+-- cannot express is refused with an 'AgentRenderError' before a process+-- would ever be created; it is never approximated with a near-miss+-- flag.+module Baikai.Provider.Claude.Agent+  ( ClaudeAgentConfig (executable, extraArgs, persistSession),+    defaultClaudeAgentConfig,+    claudeAgentCommand,+    claudeAgentThinking,+  )+where++import Baikai.Agent+  ( AgentCapability (..),+    AgentCommand (..),+    AgentPromptTransport (..),+    AgentProvider (..),+    AgentRenderError (..),+    AgentRunRequest,+  )+import Baikai.Evidence+  ( ThinkingAdjustment (..),+    ThinkingMode (..),+    ThinkingTranslation (..),+    noThinkingRequested,+  )+import Baikai.Prelude+import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel)+import Data.Generics.Labels ()+import Data.Text qualified as Text++-- | Configuration for the unattended @claude@ process.+data ClaudeAgentConfig = ClaudeAgentConfig+  { -- | The program to run, either a bare name resolved on @PATH@ or+    -- an explicit path.+    executable :: !FilePath,+    -- | Raw provider defaults an application always wants. Rendered+    -- after every structured flag and before the request's own raw+    -- arguments.+    extraArgs :: ![Text],+    -- | Whether the run may leave a resumable session on disk.+    -- Defaults to 'False', which emits @--no-session-persistence@:+    -- automation runs are one-shot, and a session file nobody will+    -- clean up is just litter. The flag only works together with @-p@,+    -- which this renderer always emits.+    persistSession :: !Bool+  }+  deriving stock (Eq, Show, Generic)++defaultClaudeAgentConfig :: ClaudeAgentConfig+defaultClaudeAgentConfig =+  ClaudeAgentConfig+    { executable = "claude",+      extraArgs = mempty,+      persistSession = False+    }++-- | Render the executable, argument vector, and prompt transport for an+-- unattended Claude Code run, or refuse the request.+--+-- The prompt appears nowhere in the argument vector: the transport is+-- 'PromptOnStdin', so a prompt beginning with a dash cannot be mistaken+-- for a flag and cannot be swallowed by a preceding variadic flag such+-- as @--allowedTools@ or @--add-dir@.+--+-- No working-directory flag is rendered, because Claude Code has none.+-- The runner sets the child's working directory from the request's+-- @workingDir@ field.+--+-- The second half of the pair describes what the request's reasoning+-- effort became on that command line, including the one collapse this+-- renderer applies. The runner cannot derive it — it never imports a+-- vendor renderer — so it travels alongside the command.+claudeAgentCommand ::+  ClaudeAgentConfig ->+  AgentRunRequest ->+  Either AgentRenderError (AgentCommand, ThinkingTranslation)+claudeAgentCommand cfg req+  | req ^. #provider /= AgentClaude =+      Left (ProviderMismatch AgentClaude (req ^. #provider))+  | otherwise = do+      permission <- permissionModeArgs (req ^. #safety . #capability)+      pure+        ( AgentCommand+            { executable = cfg ^. #executable,+              arguments =+                ["-p"]+                  <> sessionArgs cfg+                  <> modelArgs req+                  <> effortArgs req+                  <> permission+                  <> allowedToolArgs req+                  <> extraDirArgs req+                  <> fmap Text.unpack (cfg ^. #extraArgs)+                  <> fmap Text.unpack (req ^. #safety . #providerArgs),+              promptTransport = PromptOnStdin,+              promptText = req ^. #prompt+            },+          claudeAgentThinking req+        )++-- | What the request's reasoning effort became on the @claude@ command+-- line.+--+-- The adjustment is derived from 'claudeEffortValue' itself — recorded+-- exactly when the word that reaches @--effort@ differs from the+-- canonical level name — rather than from a table written beside it, so+-- the description cannot drift away from what the argument vector+-- actually carries. Today that is the single @minimal@ collapse, which+-- makes a run at @minimal@ and a run at @low@ produce byte-identical+-- command lines.+--+-- A request with no effort at all yields 'noThinkingRequested'. That is+-- a different fact from a request whose level the tool weakened: the+-- tool then applies its own default, and nothing was downgraded.+claudeAgentThinking :: AgentRunRequest -> ThinkingTranslation+claudeAgentThinking req = case req ^. #effort of+  Nothing -> noThinkingRequested+  Just lvl ->+    let wire = claudeEffortValue lvl+     in ThinkingTranslation+          { requested = Just lvl,+            mode = ThinkingModeFlag,+            effortText = Just wire,+            budgetTokens = Nothing,+            wireField = Just "--effort",+            adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl]+          }++-- | Map a capability profile onto Claude Code's @--permission-mode@.+--+-- The result is an 'Either' even though all three capabilities map+-- today. The type is the promise that an unmappable capability would be+-- refused rather than approximated: a later contributor adding a fourth+-- capability gets an incomplete-pattern warning pointing at this+-- decision instead of a silently missing flag.+permissionModeArgs :: AgentCapability -> Either AgentRenderError [String]+permissionModeArgs = \case+  -- Claude Code has no mode meaning exactly "may read, must not+  -- write". Of its six modes, `manual` and `dontAsk` can block waiting+  -- for a human and are unusable unattended, `acceptEdits` and+  -- `bypassPermissions` permit writes, and `auto` delegates the+  -- decision to a classifier whose behavior is not a stable contract.+  -- `plan` is the only mode that reliably does not modify the tree, at+  -- the documented cost of also framing the task as producing a plan.+  AgentReadOnly -> Right ["--permission-mode", "plan"]+  AgentEditWorkspace -> Right ["--permission-mode", "acceptEdits"]+  AgentFullAccess -> Right ["--permission-mode", "bypassPermissions"]++sessionArgs :: ClaudeAgentConfig -> [String]+sessionArgs cfg+  | cfg ^. #persistSession = []+  | otherwise = ["--no-session-persistence"]++-- | A blank model value must not produce @--model ""@, which Claude+-- rejects.+modelArgs :: AgentRunRequest -> [String]+modelArgs req = case Text.strip <$> req ^. #modelId of+  Nothing -> []+  Just "" -> []+  Just mid -> ["--model", Text.unpack mid]++-- | Claude's @--effort@ accepts @low|medium|high|xhigh|max@, but not+-- @minimal@, so the lowest Baikai level maps up to @low@. This matches+-- "Baikai.Provider.Claude.Interactive" exactly so the two surfaces+-- cannot drift.+effortArgs :: AgentRunRequest -> [String]+effortArgs req = case req ^. #effort of+  Nothing -> []+  Just lvl -> ["--effort", Text.unpack (claudeEffortValue lvl)]++claudeEffortValue :: ThinkingLevel -> Text+claudeEffortValue ThinkingMinimal = "low"+claudeEffortValue lvl = renderThinkingLevel lvl++-- | Join tool names with commas into one argument rather than passing+-- several values, because @--allowedTools@ is variadic and separate+-- values could absorb a following flag.+allowedToolArgs :: AgentRunRequest -> [String]+allowedToolArgs req = case req ^. #safety . #allowedTools of+  [] -> []+  tools -> ["--allowedTools", Text.unpack (Text.intercalate "," tools)]++-- | On Claude Code @--add-dir@ grants tool /access/ to a directory. The+-- identically named @codex exec@ flag grants /write/ access, so the+-- shared @extraDirs@ field means "directories this run may reach" and+-- the precise authority is provider-dependent.+extraDirArgs :: AgentRunRequest -> [String]+extraDirArgs req =+  concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs)

@@ -30,6 +30,9 @@     registerWithRegistry,     claudeMessagesProvider,     claudeMessagesStream,+    claudeMessagesStreamWith,+    SseDriver,+    anthropicStrength,     Assembler (..),     emptyAssembler,     translate,@@ -42,13 +45,16 @@ import Baikai.Cost (zeroCost) import Baikai.Cost.Pricing qualified as Pricing import Baikai.Error (BaikaiError, invalidRequest, providerError)+import Baikai.Evidence qualified as Ev+import Baikai.Evidence.Build qualified as Build import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) import Baikai.Provider.Claude.Internal.ErrorClass (classifyErrorValue, classifyException)-import Baikai.Provider.Claude.Internal.Request (mapRequest)+import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) import Baikai.Provider.Claude.Shape (streamRequestBody) import Baikai.Provider.Claude.Sse (claudeSseStreamValueWithHeaders)+import Baikai.Provider.Claude.Sse qualified as Sse import Baikai.Provider.Claude.Transport qualified as Transport import Baikai.Provider.Registry   ( ApiProvider (..),@@ -78,6 +84,7 @@ import Data.Aeson (Value) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BSL+import Data.CaseInsensitive qualified as CI import Data.Generics.Labels () import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IntMap.Strict (IntMap)@@ -89,8 +96,10 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Vector (Vector) import Data.Vector qualified as Vector+import Data.Version (showVersion) import GHC.Generics (Generic) import Network.HTTP.Types.Header (RequestHeaders)+import Paths_baikai_claude qualified as Paths import Servant.Client qualified as Client import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream@@ -109,7 +118,10 @@   ApiProvider     { apiTag = AnthropicMessages,       stream = claudeMessagesStream,-      complete = streamingComplete claudeMessagesStream+      complete = streamingComplete claudeMessagesStream,+      -- The same function 'mapRequest' uses, so the gate's answer and+      -- the wire's behaviour cannot disagree.+      describeThinking = describeThinkingFor     }  -- | Install the Anthropic Messages handler into an explicit registry.@@ -136,24 +148,64 @@ -- the masterplan's "partial output is always recoverable" promise. claudeMessagesStream ::   Model -> Context -> Options -> Stream IO AssistantMessageEvent-claudeMessagesStream m ctx opts =+claudeMessagesStream = claudeMessagesStreamWith liveSseDriver++-- | How a call physically reaches Anthropic.+--+-- Production passes 'liveSseDriver'. A test passes one that replays a+-- recorded response through the same+-- 'Baikai.Provider.Claude.Sse.sseFromResponse' the live driver uses, so+-- header capture, status classification, and SSE frame decoding are all+-- the real implementations and only the socket is missing.+type SseDriver =+  ClaudeCall ->+  (Sse.ResponseMetadata -> IO ()) ->+  (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->+  IO ()++liveSseDriver :: SseDriver+liveSseDriver call =+  claudeSseStreamValueWithHeaders+    (call ^. #clientEnv)+    (call ^. #requestHeaders)+    (call ^. #requestBody)++-- | 'claudeMessagesStream' over an explicit transport driver.+claudeMessagesStreamWith ::+  SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent+claudeMessagesStreamWith driver m ctx opts =   Stream.concatEffect $ do     setupResult <- trySync (prepareCall m ctx opts)     let setup = either (Left . exceptionToError) id setupResult     case setup of-      Left err -> Stream.fromList <$> immediateError err+      Left err -> Stream.fromList <$> immediateError m opts err       Right call -> do         ch <- newChan :: IO (Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)))         tref <- newIORef False-        _ <- forkIO (worker call ch)+        mref <- newIORef Nothing+        _ <- forkIO (worker driver call mref ch)         startTime <- getCurrentTime+        -- The request body is the envelope the two digests commit to:+        -- it is exactly the JSON this call is about to put on the wire.+        -- Credentials are not in it — they travel in the headers built+        -- separately by 'Transport.requestHeaders'.+        mkEvidence <-+          Build.prepareEvidence+            m+            opts+            Ev.TransportHttpApi+            (call ^. #thinking)+            (call ^. #requestBody)+            startTime         let initialState =               ProducerState                 { chan = ch,                   pending = [],                   assembler = emptyAssembler m startTime,                   finished = False,-                  terminalRef = tref+                  terminalRef = tref,+                  metadataRef = mref,+                  evidence = mkEvidence                 }         pure (Stream.unfoldrM step initialState) @@ -163,7 +215,13 @@   { clientEnv :: !Client.ClientEnv,     requestHeaders :: !RequestHeaders,     timeoutMs :: !(Maybe Int),-    requestBody :: !Aeson.Value+    requestBody :: !Aeson.Value,+    -- | What the caller's reasoning-effort preference became on this+    -- request, as 'mapRequest' described it. Carried from here rather+    -- than recomputed at the terminal: only the request mapper knows+    -- the host compat lookup and the max-tokens interaction that+    -- produced it.+    thinking :: !Ev.ThinkingTranslation   }   deriving stock (Generic) @@ -172,7 +230,7 @@ prepareCall m ctx opts = do   case mapRequest m ctx opts of     Left e -> pure (Left (invalidRequest e))-    Right req -> do+    Right (req, translation) -> do       let url = case m ^. #baseUrl of             "" -> "https://api.anthropic.com"             u -> u@@ -188,7 +246,8 @@               { clientEnv = env,                 requestHeaders = headers,                 timeoutMs = opts ^. #timeoutMs,-                requestBody = body+                requestBody = body,+                thinking = translation               }         ) @@ -198,17 +257,18 @@ -- the normal channel. After the SDK call returns (success or -- handled failure) we close the channel with 'Nothing'. worker ::+  SseDriver ->   ClaudeCall ->+  IORef (Maybe Sse.ResponseMetadata) ->   Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)) ->   IO ()-worker call ch = do+worker driver call metaRef ch = do   r <-     trySync $       Transport.runWithTimeout (call ^. #timeoutMs) $-        claudeSseStreamValueWithHeaders-          (call ^. #clientEnv)-          (call ^. #requestHeaders)-          (call ^. #requestBody)+        driver+          call+          (writeIORef metaRef . Just)           (writeChan ch . Just)   case r of     Right Nothing -> pure ()@@ -222,62 +282,231 @@     pending :: ![AssistantMessageEvent],     assembler :: !Assembler,     finished :: !Bool,-    terminalRef :: !(IORef Bool)+    terminalRef :: !(IORef Bool),+    -- | Where the worker leaves the response-level metadata it captured+    -- before the first event. Read on this side rather than pushed+    -- through 'chan' so the channel keeps carrying exactly one kind of+    -- thing; 'absorbMetadata' folds it into the assembler.+    metadataRef :: !(IORef (Maybe Sse.ResponseMetadata)),+    -- | Everything about this call's evidence that was knowable before+    -- the first byte came back, waiting on the terminal timestamp and+    -- outcome. 'Nothing' when the caller did not ask for evidence.+    -- 'sealTerminal' applies it.+    evidence ::+      !(Maybe (UTCTime -> Ev.CallStatus -> Maybe BaikaiError -> Ev.ModelCallEvidence))   }   deriving stock (Generic)  step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState)) step s   | (e : rest) <- s ^. #pending = do-      writeTerminal s e+      sealed <- sealTerminal s e       pure         ( Just-            ( e,+            ( sealed,               s                 & #pending .~ rest-                & #finished .~ (s ^. #finished || terminal e)+                & #finished .~ (s ^. #finished || terminal sealed)             )         )   | s ^. #finished = pure Nothing   | otherwise = do       mRaw <- readChan (s ^. #chan)+      -- After the read, because the worker writes the metadata before it+      -- writes anything onto the channel: taking it here means every+      -- path out of this branch — including the one where the channel+      -- closed without ever producing an event — sees it.+      ass0 <- absorbMetadata (s ^. #metadataRef) (s ^. #assembler)+      let s' = s & #assembler .~ ass0       case mRaw of         Nothing -> do-          alreadyTerminal <- readIORef (s ^. #terminalRef)+          alreadyTerminal <- readIORef (s' ^. #terminalRef)           if alreadyTerminal             then pure Nothing             else do               now <- getCurrentTime-              let (ev, ass') = unexpectedEoS now (s ^. #assembler)-              writeTerminal s ev+              let (ev, ass') = unexpectedEoS now ass0+              sealed <- sealTerminal (s' & #assembler .~ ass') ev               pure                 ( Just-                    ( ev,-                      s & #assembler .~ ass' & #finished .~ True+                    ( sealed,+                      s' & #assembler .~ ass' & #finished .~ True                     )                 )         Just raw -> do           now <- getCurrentTime-          let (events, ass') = translate raw (s ^. #assembler) now+          let (events, ass') = translate raw ass0 now           case events of-            [] -> step (s & #assembler .~ ass')+            [] -> step (s' & #assembler .~ ass')             (e : rest) -> do-              writeTerminal s e+              sealed <- sealTerminal (s' & #assembler .~ ass') e               pure                 ( Just-                    ( e,-                      s+                    ( sealed,+                      s'                         & #pending .~ rest                         & #assembler .~ ass'-                        & #finished .~ (s ^. #finished || terminal e)+                        & #finished .~ (s' ^. #finished || terminal sealed)                     )                 ) -writeTerminal :: ProducerState -> AssistantMessageEvent -> IO ()-writeTerminal s ev-  | terminal ev = writeIORef (s ^. #terminalRef) True-  | otherwise = pure ()+-- | Mark the stream terminated and attach the call's evidence to the+-- terminal event.+--+-- Every event this producer yields goes through here, and the three+-- sites that can produce a terminal — a translated upstream event, a+-- queued event drained from 'pending', and the unexpected-end-of-stream+-- recovery — therefore all seal identically. Doing it here rather than+-- inside 'translate' keeps that function pure; evidence construction+-- needs 'IO' for the call identifier.+--+-- A non-terminal event passes through unchanged, and so does a terminal+-- on a call whose caller asked for no evidence.+sealTerminal :: ProducerState -> AssistantMessageEvent -> IO AssistantMessageEvent+sealTerminal s ev+  | not (terminal ev) = pure ev+  | otherwise = do+      writeIORef (s ^. #terminalRef) True+      case s ^. #evidence of+        Nothing -> pure ev+        Just finish -> do+          now <- getCurrentTime+          let st = statusOf ev+              record = observeAnthropic st (s ^. #assembler) (finish now st (errorOf ev))+          pure (withEvidence record ev)+  where+    statusOf = \case+      EventDone {} -> Ev.CallSucceeded+      _ -> Ev.CallFailed+    -- The terminal payload already carries the normalized error, and+    -- 'errorTerminal' guarantees it is 'Just' on every 'EventError'.+    errorOf = \case+      EventError p -> p ^. #errorInfo+      _ -> Nothing+    -- Set through the generic-lens label rather than a record update:+    -- 'Baikai.Options.Options' also has an @evidence@ field, so under+    -- @DuplicateRecordFields@ a bare @p {evidence = ...}@ has no unique+    -- constructor to resolve to.+    withEvidence record = \case+      EventDone p -> EventDone (p & #evidence .~ Just record)+      EventError p -> EventError (p & #evidence .~ Just record)+      other -> other +-- | Replace the observed fields of a prepared evidence record with what+-- this call actually saw, and derive the strength from that.+--+-- Only ever reached on a call whose caller asked for evidence, which is+-- what makes it safe to compute the response commitment here: that+-- digest hashes the model's entire output and is the most expensive+-- thing this provider adds. The observations it reads were gathered+-- unconditionally, because each costs a lookup and each improves the+-- 'Baikai.Response.Response' for every caller.+--+-- Nothing here consults the request. An observation the provider did not+-- make stays 'Ev.Unobserved'.+observeAnthropic ::+  Ev.CallStatus -> Assembler -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence+observeAnthropic st ass ev =+  ev+    & #endpoint . #implementationVersion .~ Just claudePackageVersion+    & #observedModel .~ (ass ^. #observedModel)+    & #providerRequestId .~ (ass ^. #providerRequestId)+    & #responseId .~ maybe Ev.Unobserved Ev.Observed (ass ^. #responseId)+    & #usage .~ observedUsage ass+    & #responseCommitment .~ responseCommitment st ass+    & #strength .~ anthropicStrength (ass ^. #observedModel) (ass ^. #providerRequestId)++-- | How much an Anthropic evidence record proves, derived only from+-- what was actually observed.+--+-- Anthropic does not echo the thinking configuration it applied, so+-- 'Ev.EvidenceFullyObserved' is unreachable on this transport. That is+-- a fact about Anthropic's response shape, not a gap to paper over: a+-- reasoning-token count corroborates output volume and says nothing+-- about which effort setting was in force.+--+-- A successful HTTP status deliberately does not raise the strength. A+-- 200 means the request was accepted, not that any particular model ran.+anthropicStrength :: Ev.Observed Text -> Ev.Observed Text -> Ev.EvidenceStrength+anthropicStrength observedModel providerRequestId =+  case (observedModel, providerRequestId) of+    (Ev.Observed _, Ev.Observed _) -> Ev.EvidenceModelObserved+    (_, Ev.Observed _) -> Ev.EvidenceCorrelated+    _ -> Ev.EvidenceRequestedOnly++-- | The token accounting, but only if Anthropic actually reported it.+--+-- The assembler initialises 'usage' to zeroes, so reporting it+-- unconditionally would tell a reader the provider said this call+-- consumed nothing — which for a call that failed before any usage+-- arrived is a fabrication, and exactly what 'Ev.Observed' exists to+-- stop.+observedUsage :: Assembler -> Ev.Observed Usage.Usage+observedUsage ass+  | ass ^. #usageReported = Ev.Observed (finalUsage ass)+  | otherwise = Ev.Unobserved++-- | A commitment to what came back, on a call that produced a response.+--+-- Left 'Ev.Unobserved' otherwise: a digest of an empty envelope is a+-- real-looking value standing for a response that never arrived.+responseCommitment :: Ev.CallStatus -> Assembler -> Ev.Observed Text+responseCommitment Ev.CallSucceeded ass =+  Ev.Observed (Ev.commitmentDigest (responseEnvelope ass))+responseCommitment _ _ = Ev.Unobserved++-- | What that digest commits to: the assembled content blocks in order,+-- the stop reason, and the reported usage.+--+-- Deliberately the assembled response rather than the raw SSE bytes. Two+-- identical responses split into different frames must produce the same+-- digest, and the frame boundaries are a transport detail no verifier+-- holding the response could reproduce.+responseEnvelope :: Assembler -> Value+responseEnvelope ass =+  Aeson.object+    [ "content" Aeson..= blocksInOrder ass,+      "stop_reason" Aeson..= (ass ^. #stopReason),+      "usage" Aeson..= finalUsage ass+    ]++-- | The version of this package, for the evidence record's endpoint+-- identity. Read from the cabal-generated module rather than written as+-- a literal, which becomes a lie the first time a release misses it.+claudePackageVersion :: Text+claudePackageVersion = Text.pack (showVersion Paths.version)++-- | Fold whatever response-level metadata the worker has captured into+-- the assembler.+--+-- Idempotent: applying it again overwrites the same fields with the same+-- values, which is what lets 'step' call it on every pass rather than+-- tracking whether it has run.+absorbMetadata :: IORef (Maybe Sse.ResponseMetadata) -> Assembler -> IO Assembler+absorbMetadata ref ass = do+  meta <- readIORef ref+  pure $ case meta of+    Nothing -> ass+    Just md ->+      ass+        & #httpStatus .~ Just (md ^. #httpStatus)+        & #providerRequestId .~ correlationId md++-- | Anthropic's correlation identifier for this response, or a+-- gateway's if Anthropic's own is absent.+--+-- The preference order is 'Sse.capturedHeaderNames' itself, so the+-- allow-list and the preference cannot disagree. Nothing is invented:+-- a response carrying none of those headers leaves this+-- 'Ev.Unobserved'.+correlationId :: Sse.ResponseMetadata -> Ev.Observed Text+correlationId md =+  case [v | n <- Sse.capturedHeaderNames, Just v <- [lookup (headerName n) (md ^. #headers)]] of+    (v : _) -> Ev.Observed v+    [] -> Ev.Unobserved+  where+    headerName = Text.decodeUtf8 . CI.foldedCase+ terminal :: AssistantMessageEvent -> Bool terminal = \case   EventDone {} -> True@@ -290,9 +519,16 @@ unexpectedEoS now ass =   let errText = "claude stream ended without message_stop"       msg = finalMessageOnError ass now errText-   in (EventError (errorTerminal (ass ^. #responseId) Stop.ErrorReason msg (providerError errText)), ass)+   in (EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg (providerError errText)), ass)  -- | Translation state across one streaming call.+--+-- The four fields below @stopReason@ are what this call /observed/, as+-- distinct from what it requested. They are kept here rather than+-- derived at the terminal because this record is the only state that+-- survives from the first event to the last, and because an observation+-- that never arrived must stay 'Ev.Unobserved' rather than falling back+-- to the caller's configuration. data Assembler = Assembler   { model :: !Model,     start :: !UTCTime,@@ -305,7 +541,22 @@     toolArgsBuf :: !(IntMap Text),     toolMeta :: !(IntMap (Text, Text)),     usage :: !Usage.Usage,-    stopReason :: !Stop.StopReason+    stopReason :: !Stop.StopReason,+    -- | Anthropic's own correlation identifier for this call, from the+    -- response headers.+    providerRequestId :: !(Ev.Observed Text),+    -- | The model identifier Anthropic reported running, from+    -- @message_start@. Never the configured model.+    observedModel :: !(Ev.Observed Text),+    -- | The response's HTTP status. Recorded because the transport has+    -- it; 'Baikai.Evidence.ModelCallEvidence' has no field for it, and+    -- inventing one is EP-1's decision to make, not this module's.+    httpStatus :: !(Maybe Int),+    -- | Whether Anthropic actually reported token counts, as opposed to+    -- 'usage' still holding the zeroes it was initialised with. Without+    -- this a failed call would claim the provider reported consuming+    -- nothing.+    usageReported :: !Bool   }   deriving stock (Generic) @@ -323,7 +574,11 @@       toolArgsBuf = IntMap.empty,       toolMeta = IntMap.empty,       usage = Usage.zeroUsage,-      stopReason = Stop.Stop+      stopReason = Stop.Stop,+      providerRequestId = Ev.Unobserved,+      observedModel = Ev.Unobserved,+      httpStatus = Nothing,+      usageReported = False     }  translate ::@@ -334,7 +589,7 @@ translate raw ass now = case raw of   Left be ->     let msg = finalMessageOnError ass now (be ^. #message)-     in ([EventError (errorTerminal (ass ^. #responseId) Stop.ErrorReason msg be)], ass)+     in ([EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg be)], ass)   Right ev -> translateEvent ev ass now  translateEvent ::@@ -346,7 +601,16 @@   Messages.Ping -> ([], ass)   Messages.Message_Start {Messages.message = mr} ->     let usage0 = anthroUsageToBaikai (mr ^. #usage)-        ass' = ass & #responseId .~ Just (mr ^. #id) & #usage .~ usage0+        ass' =+          ass+            & #responseId .~ Just (mr ^. #id)+            -- The provider's value, never the caller's. The SDK's+            -- @model@ field is not optional, so a @message_start@ that+            -- arrives at all is a genuine observation; a stream that+            -- fails before one arrives leaves this 'Ev.Unobserved'.+            & #observedModel .~ Ev.Observed (mr ^. #model)+            & #usage .~ usage0+            & #usageReported .~ True         skeleton = skeletonMessage ass' now      in ([EventStart StartPayload {partial = skeleton, responseId = Just (mr ^. #id)}], ass')   Messages.Content_Block_Start {Messages.index = idx, Messages.content_block = block} ->@@ -364,7 +628,7 @@             & #outputTokens .~ outputTokensFinal             & #totalTokens               .~ ((u ^. #inputTokens) + outputTokensFinal + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens))-     in ([], ass & #stopReason .~ stopR & #usage .~ u')+     in ([], ass & #stopReason .~ stopR & #usage .~ u' & #usageReported .~ True)   Messages.Message_Stop ->     let reason = ass ^. #stopReason         refusal = providerError "Anthropic refused to generate a response (stop_reason=refusal)"@@ -374,15 +638,15 @@             else finalMessage ass now         terminalEvent =           if reason == Stop.ErrorReason-            then EventError (errorTerminal (ass ^. #responseId) reason msg refusal)-            else EventDone (doneTerminal (ass ^. #responseId) reason msg)+            then EventError (errorTerminal Nothing (ass ^. #responseId) reason msg refusal)+            else EventDone (doneTerminal Nothing (ass ^. #responseId) reason msg)      in ([terminalEvent], ass)   Messages.Error {Messages.error = errVal} ->     let errText = renderAnthropicError errVal         mErr = classifyErrorValue errVal         msg = finalMessageOnError ass now errText         errInfo = fromMaybe (providerError errText) mErr-     in ([EventError (errorTerminal (ass ^. #responseId) Stop.ErrorReason msg errInfo)], ass)+     in ([EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg errInfo)], ass)  handleBlockStart ::   Int ->@@ -530,37 +794,35 @@         Msg.timestamp = Just (ass ^. #start)       } +-- | The assembler's token accounting with this model's pricing applied.+-- Shared so the terminal message and the evidence record cannot report+-- two different figures for one call.+finalUsage :: Assembler -> Usage.Usage+finalUsage ass =+  let usageBare = ass ^. #usage+   in usageBare & #cost .~ Pricing.computeCost (ass ^. #model) usageBare+ finalMessage :: Assembler -> UTCTime -> Msg.Message finalMessage ass now =-  let blocks = blocksInOrder ass-      m = ass ^. #model-      usageBare = ass ^. #usage-      computed = Pricing.computeCost m usageBare-      usage' = usageBare & #cost .~ computed-   in Msg.AssistantMessage-        Msg.AssistantPayload-          { Msg.content = blocks,-            Msg.usage = usage',-            Msg.stopReason = ass ^. #stopReason,-            Msg.errorMessage = Nothing,-            Msg.timestamp = Just now-          }+  Msg.AssistantMessage+    Msg.AssistantPayload+      { Msg.content = blocksInOrder ass,+        Msg.usage = finalUsage ass,+        Msg.stopReason = ass ^. #stopReason,+        Msg.errorMessage = Nothing,+        Msg.timestamp = Just now+      }  finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message finalMessageOnError ass now reason =-  let blocks = blocksInOrder ass-      m = ass ^. #model-      usageBare = ass ^. #usage-      computed = Pricing.computeCost m usageBare-      usage' = usageBare & #cost .~ computed-   in Msg.AssistantMessage-        Msg.AssistantPayload-          { Msg.content = blocks,-            Msg.usage = usage',-            Msg.stopReason = Stop.ErrorReason,-            Msg.errorMessage = Just reason,-            Msg.timestamp = Just now-          }+  Msg.AssistantMessage+    Msg.AssistantPayload+      { Msg.content = blocksInOrder ass,+        Msg.usage = finalUsage ass,+        Msg.stopReason = Stop.ErrorReason,+        Msg.errorMessage = Just reason,+        Msg.timestamp = Just now+      }  blocksInOrder :: Assembler -> Vector Content.AssistantContent blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed))@@ -568,8 +830,12 @@ -- | The immediate "request invalid" stream — emitted when -- 'mapRequest' fails or 'prepareCall' is otherwise unable to build -- a valid SDK request.-immediateError :: BaikaiError -> IO [AssistantMessageEvent]-immediateError err = do+-- | The immediate "request invalid" stream.+--+-- Nothing was sent, so there is no wire body to digest and the evidence+-- commits to 'Build.dispatchEnvelope' instead — see its documentation.+immediateError :: Model -> Options -> BaikaiError -> IO [AssistantMessageEvent]+immediateError m opts err = do   now <- getCurrentTime   let errText = err ^. #message   let msg =@@ -581,9 +847,20 @@               Msg.errorMessage = Just errText,               Msg.timestamp = Just now             }+  ev <-+    Build.minimalEvidence+      m+      opts+      Ev.TransportHttpApi+      Ev.noThinkingRequested+      (Build.dispatchEnvelope m opts)+      now+      now+      Ev.CallFailed+      (Just err)   pure     [ EventStart StartPayload {partial = msg, responseId = Nothing},-      EventError (errorTerminal Nothing Stop.ErrorReason msg err)+      EventError (errorTerminal ev Nothing Stop.ErrorReason msg err)     ]  trySync :: IO a -> IO (Either SomeException a)

@@ -6,19 +6,28 @@ -- For non-default executable paths or extra args, use 'registerWith' -- and supply a custom 'ClaudeCliConfig'. ----- The CLI provider always returns a 'Response' whose embedded--- assistant message carries zero token counts (and therefore zero--- cost): the @claude@ CLI runs under a flat subscription, so--- per-token billing does not apply. CLI providers do not participate--- in tool calling. Provider failures are returned in-band as--- error-shaped responses; the masterplan's Decision Log records the+-- The 'Response' this provider returns carries whatever the tool+-- reported about its own run: the token counts and total cost from the+-- result event's @usage@ block, and the tool's @session_id@ as the+-- response identifier. A tool that reports none of that yields zeroes+-- and 'Nothing', which is an accurate record of its silence rather+-- than a claim that the call was free. CLI providers do not+-- participate in tool calling. Provider failures are returned in-band+-- as error-shaped responses; the masterplan's Decision Log records the -- reasoning.+--+-- Evidence from this transport is deliberately weaker than from the+-- Messages API. A tool that exits zero has demonstrated that it ran,+-- not which model served the request, so a successful exit never+-- raises the recorded 'Baikai.Evidence.EvidenceStrength' — see+-- 'Baikai.Provider.Cli.Internal.subprocessStrength'. module Baikai.Provider.Claude.Cli   ( ClaudeCliConfig,     executable,     extraArgs,     workingDir,     claudeCliCommand,+    claudeCliThinking,     defaultClaudeCliConfig,     claudeCliProvider,     register,@@ -31,7 +40,9 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context)-import Baikai.Error (BaikaiError, decodeError, processError, providerError)+import Baikai.Error (BaikaiError, processError, providerError)+import Baikai.Evidence qualified as Ev+import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..)) import Baikai.Model (Model) import Baikai.Options (Options)@@ -46,9 +57,9 @@ import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) import Baikai.ThinkingLevel (ThinkingLevel (ThinkingMinimal), renderThinkingLevel)-import Baikai.Usage (zeroUsage)-import Control.Exception (SomeAsyncException (..), SomeException, displayException, fromException, throwIO, try)-import Control.Lens ((^.))+import Baikai.Usage (Usage, zeroUsage)+import Control.Exception (SomeException, displayException, fromException)+import Control.Lens ((&), (.~), (^.)) import Cradle   ( ExitCode (..),     StderrRaw (..),@@ -59,18 +70,11 @@     setNoStdin,     setWorkingDir,   )-import Data.Aeson (FromJSON, Value (..), eitherDecodeStrict)-import Data.Aeson qualified as Aeson-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Aeson.Types (parseEither, parseJSON)-import Data.ByteString (ByteString)-import Data.Function ((&)) import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)-import Data.Vector (Vector) import Data.Vector qualified as Vector import GHC.Generics (Generic) @@ -100,7 +104,10 @@   ApiProvider     { apiTag = AnthropicMessagesCli,       stream = liftCompleteToStream (runClaudeCli cfg),-      complete = runClaudeCli cfg+      complete = runClaudeCli cfg,+      -- The model plays no part: this transport's only reasoning+      -- control is a command-line flag derived from Options alone.+      describeThinking = \_ opts -> claudeCliThinking opts     }  -- | Install the CLI handler with a caller-supplied config.@@ -163,14 +170,30 @@ claudeEffortValue ThinkingMinimal = "low" claudeEffortValue lvl = renderThinkingLevel lvl --- | The shape of @claude -p --output-format json@ stdout.-data ClaudeCliResult = ClaudeCliResult-  { result :: !Text,-    is_error :: !Bool,-    session_id :: !(Maybe Text)-  }-  deriving stock (Eq, Show, Generic)-  deriving anyclass (FromJSON)+-- | What the caller's reasoning-effort preference became on this+-- transport's command line.+--+-- Derived from 'claudeEffortValue' itself rather than from a table+-- written beside it: the adjustment is recorded exactly when the word+-- that reaches @--effort@ differs from the canonical level name, so the+-- description cannot drift away from what the argument vector actually+-- carries. At present that is the single @minimal -> low@ collapse, and+-- a caller asking for @minimal@ and a caller asking for @low@ produce+-- byte-identical command lines — which is precisely why the collapse+-- has to be written down somewhere.+claudeCliThinking :: Options -> Ev.ThinkingTranslation+claudeCliThinking opts = case opts ^. #thinking of+  Nothing -> Ev.noThinkingRequested+  Just lvl ->+    let wire = claudeEffortValue lvl+     in Ev.ThinkingTranslation+          { requested = Just lvl,+            mode = Ev.ThinkingModeFlag,+            effortText = Just wire,+            budgetTokens = Nothing,+            wireField = Just "--effort",+            adjustments = [Ev.EffortClamped lvl wire | wire /= renderThinkingLevel lvl]+          }  systemPromptArgs :: Context -> [String] systemPromptArgs ctx = case ctx ^. #systemPrompt of@@ -182,57 +205,110 @@   "" -> []   mid -> ["--model", Text.unpack mid] -decodeResult :: ByteString -> Either BaikaiError ClaudeCliResult-decodeResult bs = case eitherDecodeStrict bs of-  Left err -> Left (decodeError (Text.pack err))-  Right (Aeson.Array events) -> case findResultEvent events of-    Nothing -> Left (decodeError "claude -p: no result event in stdout array")-    Just ev -> case parseEither parseJSON ev of-      Left err -> Left (decodeError (Text.pack err))-      Right r -> Right r-  Right v@(Aeson.Object _) -> case parseEither parseJSON v of-    Left err -> Left (decodeError (Text.pack err))-    Right r -> Right r-  Right _ -> Left (decodeError "claude -p: expected JSON object or array")--findResultEvent :: Vector Value -> Maybe Value-findResultEvent = Vector.find isResult-  where-    isResult (Aeson.Object o) = case KeyMap.lookup "type" o of-      Just (Aeson.String "result") -> True-      _ -> False-    isResult _ = False- runClaudeCli :: ClaudeCliConfig -> Model -> Context -> Options -> IO Resp.Response runClaudeCli cfg m ctx opts = do   let (exe, args) = claudeCliCommand cfg m ctx opts   start <- getCurrentTime   executed <--    trySync $+    Internal.trySync $       run $         cmd exe           & addArgs args           & setNoStdin           & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir   end <- getCurrentTime+  -- The argument vector is the envelope: for a subprocess it is what+  -- crossed the boundary, and there is nothing else to describe the+  -- launch with. Built lazily and dropped unforced when the caller+  -- asked for no evidence.+  let evidenceFor mReport st mErr = do+        prepared <-+          Build.minimalEvidence+            m+            opts+            Ev.TransportSubprocess+            (claudeCliThinking opts)+            (Internal.argvEnvelope exe args)+            start+            end+            st+            mErr+        traverse (observeClaudeCli exe mReport st) prepared+      failedWith mReport err = do+        ev <- evidenceFor mReport Ev.CallFailed (Just err)+        let resp = Resp.errorResponse m end (millisBetween start end) err+        pure resp {Resp.evidence = ev, Resp.responseId = mReport >>= (^. #sessionId)}   case executed of-    Left ex -> pure (Resp.errorResponse m end (millisBetween start end) (exceptionToError ex))+    Left ex -> failedWith Nothing (exceptionToError ex)     Right (exitCode, StdoutRaw out, StderrRaw err) -> case exitCode of-      ExitFailure n -> pure (Resp.errorResponse m end (millisBetween start end) (processError n (Internal.decodeUtf8Lenient err)))-      ExitSuccess -> case decodeResult out of-        Left e -> pure (Resp.errorResponse m end (millisBetween start end) e)+      ExitFailure n -> failedWith Nothing (processError n (Internal.decodeUtf8Lenient err))+      ExitSuccess -> case Internal.decodeClaudeCliResult out of+        Left e -> failedWith Nothing e         Right r ->-          if is_error r-            then pure (Resp.errorResponse m end (millisBetween start end) (providerError (result r)))-            else pure (mkResponse m start end (result r))+          if r ^. #isError+            then failedWith (Just r) (providerError (r ^. #result))+            else do+              ev <- evidenceFor (Just r) Ev.CallSucceeded Nothing+              let resp = mkResponse m start end r+              pure resp {Resp.evidence = ev} -mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response-mkResponse m start end body =+-- | Fill in what the tool reported and what baikai knows about the+-- process it launched.+--+-- Only ever reached on a call whose caller asked for evidence, which is+-- what makes the version probe affordable here: it spawns a whole extra+-- subprocess, and charging that to a caller who only wanted an answer+-- from a tool they were about to run anyway would be a visible cost on+-- the cheapest possible call. The parsing it reads is the opposite case+-- and happens unconditionally, because the provider had already decoded+-- the tool's output to find the assistant text.+--+-- Nothing here consults the request. A field the tool did not report+-- stays 'Ev.Unobserved'.+observeClaudeCli ::+  FilePath ->+  Maybe Internal.ClaudeCliReport ->+  Ev.CallStatus ->+  Ev.ModelCallEvidence ->+  IO Ev.ModelCallEvidence+observeClaudeCli exe mReport st ev = do+  identity <- Internal.executableIdentity exe+  let session = observedOf (mReport >>= (^. #sessionId))+      reported = observedOf (mReport >>= (^. #reportedModel))+      used = mReport >>= (^. #usage)+  pure $+    ev+      -- A subprocess has no endpoint URL. Recording the model's base+      -- URL here would suggest an HTTP request that was never made, so+      -- the resolved executable path takes its place.+      & #endpoint . #endpoint .~ Just (fromMaybe (Text.pack exe) (identity ^. #resolvedPath))+      -- For this transport the tool is the implementation, so its own+      -- version is what determines behaviour — not this package's.+      & #endpoint . #implementationVersion .~ (identity ^. #version)+      & #responseId .~ session+      & #observedModel .~ reported+      & #usage .~ observedOf used+      & #responseCommitment .~ commitment used+      & #strength .~ Internal.subprocessStrength session reported+  where+    commitment used = case (st, mReport) of+      (Ev.CallSucceeded, Just r) ->+        Ev.Observed+          ( Ev.commitmentDigest+              (Internal.cliResponseEnvelope (r ^. #result) (fromMaybe zeroUsage used))+          )+      _ -> Ev.Unobserved++observedOf :: Maybe a -> Ev.Observed a+observedOf = maybe Ev.Unobserved Ev.Observed++mkResponse :: Model -> UTCTime -> UTCTime -> Internal.ClaudeCliReport -> Resp.Response+mkResponse m start end r =   Resp.Response     { Resp.message =         AssistantPayload-          { content = Vector.singleton (AssistantText (TextContent body)),-            usage = zeroUsage,+          { content = Vector.singleton (AssistantText (TextContent (r ^. #result))),+            usage = reportedUsage r,             stopReason = Stop,             errorMessage = Nothing,             timestamp = Just end@@ -240,23 +316,22 @@       Resp.model = m,       Resp.api = AnthropicMessagesCli,       Resp.provider = m ^. #provider,-      Resp.responseId = Nothing,+      Resp.responseId = r ^. #sessionId,       Resp.latencyMs = millisBetween start end,-      Resp.errorInfo = Nothing+      Resp.errorInfo = Nothing,+      Resp.evidence = Nothing     } +-- | The tool's own token counts, or zeroes when it reported none.+--+-- 'Resp.Response' has nowhere to say "the tool stayed silent", so a+-- silent tool still yields 'zeroUsage' here. The evidence record does+-- have somewhere to say it, and says it: see 'observeClaudeCli'.+reportedUsage :: Internal.ClaudeCliReport -> Usage+reportedUsage r = fromMaybe zeroUsage (r ^. #usage)+ millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double))--trySync :: IO a -> IO (Either SomeException a)-trySync action = do-  r <- try action-  case r of-    Left e-      | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) ->-          throwIO e-      | otherwise -> pure (Left e)-    Right a -> pure (Right a)  exceptionToError :: SomeException -> BaikaiError exceptionToError e = fromMaybe (providerError (Text.pack (displayException e))) (fromException e)

@@ -5,6 +5,11 @@ -- "Baikai.Provider.Claude.Cli": that module drives @claude -p@ as a -- batch completion provider, while this module starts the interactive -- terminal UI and returns only after the CLI exits.+--+-- A safety policy Claude Code cannot express is refused before launch+-- rather than dropped: both the pure command builder and the launcher+-- return 'Either' 'AgentRenderError', and a 'Left' means no process was+-- started. module Baikai.Provider.Claude.Interactive   ( ClaudeInteractiveConfig,     executable,@@ -15,12 +20,15 @@   ) where +import Baikai.Agent (AgentProvider (..), AgentRenderError (..)) import Baikai.Interactive   ( InteractiveLaunchRequest,     InteractiveLaunchResult,     InteractiveProvider (..),     InteractiveSafety (..),     interactiveLaunchResult,+    renderCodexApprovalPolicy,+    renderCodexSandboxMode,   ) import Baikai.Prelude import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel)@@ -46,32 +54,47 @@ -- Code launch. The final positional argument is the initial user -- prompt. The prompt is preceded by @--@ because Claude's -- @--allowedTools@ and @--add-dir@ flags are variadic.+--+-- Returns 'Left' when the request's safety policy is one Claude Code+-- cannot express, so a caller who asked to be constrained never+-- receives a command that is not. claudeInteractiveCommand ::-  ClaudeInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String])-claudeInteractiveCommand cfg req =-  ( cfg ^. #executable,-    modelArgs req-      <> effortArgs req-      <> systemPromptArgs req-      <> extraDirArgs req-      <> safetyArgs req-      <> fmap Text.unpack (cfg ^. #extraArgs)-      <> fmap Text.unpack (req ^. #extraArgs)-      <> ["--", Text.unpack (req ^. #userPrompt)]-  )+  ClaudeInteractiveConfig ->+  InteractiveLaunchRequest ->+  Either AgentRenderError (FilePath, [String])+claudeInteractiveCommand cfg req = do+  safety <- safetyArgs req+  pure+    ( cfg ^. #executable,+      modelArgs req+        <> effortArgs req+        <> systemPromptArgs req+        <> extraDirArgs req+        <> safety+        <> fmap Text.unpack (cfg ^. #extraArgs)+        <> fmap Text.unpack (req ^. #extraArgs)+        <> ["--", Text.unpack (req ^. #userPrompt)]+    )  -- | Launch Claude Code with inherited stdin, stdout, and stderr so -- the local CLI owns the interactive terminal experience.+--+-- A 'Left' result means no process was started: the requested safety+-- policy was refused before launch. A 'Right' carrying a non-zero+-- 'System.Exit.ExitCode' means the session ran and exited non-zero. launchClaudeInteractive ::-  ClaudeInteractiveConfig -> InteractiveLaunchRequest -> IO InteractiveLaunchResult-launchClaudeInteractive cfg req = do-  let (exe, args) = claudeInteractiveCommand cfg req-  code <--    run $-      cmd exe-        & addArgs args-        & maybe id setWorkingDir (req ^. #workingDir)-  pure (interactiveLaunchResult InteractiveClaude code)+  ClaudeInteractiveConfig ->+  InteractiveLaunchRequest ->+  IO (Either AgentRenderError InteractiveLaunchResult)+launchClaudeInteractive cfg req = case claudeInteractiveCommand cfg req of+  Left err -> pure (Left err)+  Right (exe, args) -> do+    code <-+      run $+        cmd exe+          & addArgs args+          & maybe id setWorkingDir (req ^. #workingDir)+    pure (Right (interactiveLaunchResult InteractiveClaude code))  modelArgs :: InteractiveLaunchRequest -> [String] modelArgs req = case Text.strip <$> req ^. #modelId of@@ -100,10 +123,25 @@ extraDirArgs req =   concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs) -safetyArgs :: InteractiveLaunchRequest -> [String]+-- | 'DefaultSafety' means the caller declined to specify a policy, so+-- rendering nothing honors it rather than downgrading it. An empty+-- allow-list restricts nothing, so it too renders nothing. Only a+-- Codex sandbox policy is a restriction Claude Code cannot express,+-- and that is refused.+safetyArgs :: InteractiveLaunchRequest -> Either AgentRenderError [String] safetyArgs req = case req ^. #safety of-  ClaudeAllowedTools [] -> []+  DefaultSafety -> Right []+  ClaudeAllowedTools [] -> Right []   ClaudeAllowedTools tools ->-    ["--allowedTools", Text.unpack (Text.intercalate "," tools)]-  DefaultSafety -> []-  CodexSandbox _ _ -> []+    Right ["--allowedTools", Text.unpack (Text.intercalate "," tools)]+  CodexSandbox sandbox approval ->+    Left+      ( SafetyNotExpressible+          AgentClaude+          ( "Claude Code cannot express a Codex sandbox policy ("+              <> renderCodexSandboxMode sandbox+              <> ", "+              <> renderCodexApprovalPolicy approval+              <> "); use ClaudeAllowedTools, or DefaultSafety to accept Claude's own default"+          )+      )

@@ -6,6 +6,8 @@ -- compatibility guarantees. Import the public provider module for stable application code. module Baikai.Provider.Claude.Internal.Request   ( mapRequest,+    planThinking,+    describeThinkingFor,     ThinkingPlan (..),     computeThinking,   )@@ -15,15 +17,21 @@ import Baikai.Compat (AnthropicMessagesCompat (..), AnthropicThinkingStyle (..)) import Baikai.Content qualified as Content import Baikai.Context (Context (..))+import Baikai.Evidence+  ( ThinkingAdjustment (..),+    ThinkingMode (..),+    ThinkingTranslation (..),+    noThinkingRequested,+  ) import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) import Baikai.ResponseFormat (ResponseFormat (..))-import Baikai.ThinkingLevel (ThinkingLevel (..), thinkingTokenBudget)+import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel, thinkingTokenBudget) import Baikai.Tool qualified as Tool import Claude.V1.Messages qualified as Messages import Claude.V1.Tool qualified as ClaudeTool-import Control.Lens ((^.))+import Control.Lens ((%~), (&), (.~), (^.)) import Data.Aeson ((.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Base64 qualified as Base64@@ -43,19 +51,25 @@ -- accept Context/Options directly). -- ============================================================ -mapRequest :: Model -> Context -> Options -> Either Text Messages.CreateMessage+-- | Map a baikai request onto the SDK's 'Messages.CreateMessage', and+-- describe what the caller's reasoning-effort preference became on the+-- way.+--+-- The 'ThinkingTranslation' is returned rather than reconstructed+-- downstream because this is the only place that knows all of it: the+-- host compatibility lookup, the model's reasoning capability, the+-- adaptive effort vocabulary, and the max-tokens interaction below all+-- feed into it. A trace sink asked to re-derive it would have to+-- reimplement every one of them.+mapRequest ::+  Model -> Context -> Options -> Either Text (Messages.CreateMessage, ThinkingTranslation) mapRequest m ctx opts = do   msgs <- traverse mapMessage (Vector.toList (ctx ^. #messages))   let compat = anthropicMessagesCompatFor m       cap = m ^. #maxOutputTokens       baseTokens = fromMaybe cap (opts ^. #maxTokens)       clamp n = if cap == 0 then n else min n cap-      plan0 = computeThinking compat m (opts ^. #thinking)-      requested = clamp (baseTokens + fromMaybe 0 (budget plan0))-      plan = case budget plan0 of-        Just b-          | requested <= b -> emptyThinkingPlan-        _ -> plan0+      (plan, translation) = planThinking m opts       maxTokensField_ = case budget plan of         Just b -> clamp (baseTokens + b)         Nothing -> clamp baseTokens@@ -71,21 +85,63 @@         Nothing -> Nothing       outputConfigField = mergeEffort (effort plan) (fmap mkAnthropicOutputConfig (opts ^. #responseFormat))   pure-    Messages._CreateMessage-      { Messages.model = m ^. #modelId,-        Messages.messages = Vector.fromList msgs,-        Messages.max_tokens = maxTokensField_,-        Messages.system = fmap Messages.SystemPromptText (ctx ^. #systemPrompt),-        Messages.temperature = opts ^. #temperature,-        Messages.top_p = opts ^. #topP,-        Messages.stop_sequences = opts ^. #stopSequences,-        Messages.tools = toolsField,-        Messages.tool_choice = toolChoiceField,-        Messages.cache_control = cacheControlField,-        Messages.thinking = field plan,-        Messages.output_config = outputConfigField-      }+    ( Messages._CreateMessage+        { Messages.model = m ^. #modelId,+          Messages.messages = Vector.fromList msgs,+          Messages.max_tokens = maxTokensField_,+          Messages.system = fmap Messages.SystemPromptText (ctx ^. #systemPrompt),+          Messages.temperature = opts ^. #temperature,+          Messages.top_p = opts ^. #topP,+          Messages.stop_sequences = opts ^. #stopSequences,+          Messages.tools = toolsField,+          Messages.tool_choice = toolChoiceField,+          Messages.cache_control = cacheControlField,+          Messages.thinking = field plan,+          Messages.output_config = outputConfigField+        },+      translation+    ) +-- | The thinking plan for one request and the description of how it got+-- there, including the max-tokens interaction that can discard an+-- already-computed budget.+--+-- Factored out of 'mapRequest' so the pre-dispatch strictness gate can+-- ask what /would/ happen without building a request. Both callers go+-- through this one function on purpose: a gate that reimplemented the+-- ceiling arithmetic would miss the least discoverable of baikai's+-- downgrades the first time either side changed, and it would miss it+-- silently.+--+-- The interaction it captures: the output-token ceiling this request+-- resolves to still has the thinking budget inside it, the budget has to+-- fit, and when it does not the entire thinking plan is dropped. A+-- caller who lowered @maxTokens@ on a reasoning model silently loses+-- thinking, which is why both colliding numbers are recorded in the+-- adjustment.+planThinking :: Model -> Options -> (ThinkingPlan, ThinkingTranslation)+planThinking m opts =+  let compat = anthropicMessagesCompatFor m+      cap = m ^. #maxOutputTokens+      baseTokens = fromMaybe cap (opts ^. #maxTokens)+      clamp n = if cap == 0 then n else min n cap+      (plan0, translation0) = computeThinking compat m (opts ^. #thinking)+      resolvedCeiling = clamp (baseTokens + fromMaybe 0 (budget plan0))+   in case (budget plan0, translation0 ^. #requested) of+        (Just b, Just lvl)+          | resolvedCeiling <= b ->+              ( emptyThinkingPlan,+                dropThinking (ThinkingDroppedBudgetExceeded lvl b resolvedCeiling) translation0+              )+        _ -> (plan0, translation0)++-- | What this provider would do with the caller's reasoning-effort+-- request, without building or sending anything. The+-- 'Baikai.Provider.Registry.describeThinking' implementation for the+-- Anthropic Messages provider.+describeThinkingFor :: Model -> Options -> ThinkingTranslation+describeThinkingFor m opts = snd (planThinking m opts)+ mergeEffort :: Maybe Text -> Maybe Messages.OutputConfig -> Maybe Messages.OutputConfig mergeEffort Nothing cfg = cfg mergeEffort (Just e) Nothing = Just (Messages.effortConfig e)@@ -156,27 +212,64 @@       budget = Nothing     } +-- | Build the SDK's thinking configuration and, beside it, the+-- provider-neutral description of what the caller's level became.+--+-- The two travel together because they are two views of one decision.+-- Returning only the first is what this provider used to do, and it is+-- why a caller could never tell an honoured request from a dropped one. computeThinking ::   AnthropicMessagesCompat ->   Model ->   Maybe ThinkingLevel ->-  ThinkingPlan-computeThinking _ _ Nothing = emptyThinkingPlan+  (ThinkingPlan, ThinkingTranslation)+computeThinking _ _ Nothing = (emptyThinkingPlan, noThinkingRequested) computeThinking compat m (Just lvl)-  | not (m ^. #reasoning) = emptyThinkingPlan+  | not (m ^. #reasoning) =+      ( emptyThinkingPlan,+        ThinkingTranslation+          { requested = Just lvl,+            mode = ThinkingModeUnsupported,+            effortText = Nothing,+            budgetTokens = Nothing,+            wireField = Nothing,+            adjustments = [ThinkingDroppedUnsupportedModel lvl]+          }+      )   | thinkingStyle compat == AnthropicThinkingAdaptive =-      ThinkingPlan-        { field = Just Messages.ThinkingAdaptive,-          effort = adaptiveEffort lvl,-          budget = Nothing-        }+      let e = adaptiveEffort lvl+       in ( ThinkingPlan+              { field = Just Messages.ThinkingAdaptive,+                effort = e,+                budget = Nothing+              },+            ThinkingTranslation+              { requested = Just lvl,+                mode = ThinkingModeAdaptive,+                effortText = e,+                budgetTokens = Nothing,+                wireField = Just "thinking",+                adjustments = adaptiveAdjustments lvl e+              }+          )   | otherwise =       let b = thinkingTokenBudget lvl-       in ThinkingPlan-            { field = Just Messages.ThinkingEnabled {Messages.budget_tokens = b},-              effort = Nothing,-              budget = Just b-            }+       in ( ThinkingPlan+              { field = Just Messages.ThinkingEnabled {Messages.budget_tokens = b},+                effort = Nothing,+                budget = Just b+              },+            ThinkingTranslation+              { requested = Just lvl,+                mode = ThinkingModeBudget,+                effortText = Nothing,+                budgetTokens = Just b,+                -- A budget expresses the requested level exactly, so+                -- there is nothing to adjust.+                wireField = Just "thinking",+                adjustments = []+              }+          )  adaptiveEffort :: ThinkingLevel -> Maybe Text adaptiveEffort = \case@@ -186,6 +279,36 @@   ThinkingHigh -> Nothing   ThinkingXHigh -> Just "xhigh"   ThinkingMax -> Just "max"++-- | What Anthropic's adaptive vocabulary did to the requested level.+--+-- Derived from what 'adaptiveEffort' actually produced rather than from+-- a second table beside it, so the two cannot drift. 'Nothing' means no+-- effort field is sent at all, which leaves the request+-- wire-indistinguishable from a caller who expressed no preference and+-- took Anthropic's own default depth. An effort word that differs from+-- the level's canonical name is a clamp onto the nearest word the+-- adaptive vocabulary has — Anthropic's has no @minimal@.+adaptiveAdjustments :: ThinkingLevel -> Maybe Text -> [ThinkingAdjustment]+adaptiveAdjustments lvl = \case+  Nothing -> [EffortOmitted lvl]+  Just wire+    | wire == renderThinkingLevel lvl -> []+    | otherwise -> [EffortClamped lvl wire]++-- | Record that, after all, nothing about thinking reached the wire.+--+-- Every field describing a wire value is cleared, because after the drop+-- there is none. The adjustment is appended rather than replacing the+-- list so a reader sees the order things were applied in.+dropThinking :: ThinkingAdjustment -> ThinkingTranslation -> ThinkingTranslation+dropThinking adj t =+  t+    & #mode .~ ThinkingModeUnsupported+    & #effortText .~ Nothing+    & #budgetTokens .~ Nothing+    & #wireField .~ Nothing+    & #adjustments %~ (<> [adj])  -- | Map a baikai 'Tool.Tool' into the upstream Anthropic -- 'ClaudeTool.ToolDefinition'. The SDK helper is used to populate

@@ -11,6 +11,8 @@     claudeSseStreamValue,     claudeSseStreamValueWithHeaders,     sseFromResponse,+    ResponseMetadata (..),+    capturedHeaderNames,   ) where @@ -20,25 +22,73 @@ import Data.Aeson qualified as Aeson import Data.ByteString qualified as SBS import Data.ByteString.Char8 qualified as S8+import Data.CaseInsensitive (CI) import Data.CaseInsensitive qualified as CI import Data.IORef qualified as IORef import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error qualified as Text+import GHC.Generics (Generic) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types.Header (RequestHeaders) import Network.HTTP.Types.Status qualified as Status import Servant.Client qualified as Client +-- | Response-level metadata captured once, before the first event.+--+-- Header capture is an allow-list: a response header is recorded only+-- if its name appears in 'capturedHeaderNames'. A denylist would leak+-- whatever header a future gateway decides to add.+--+-- Names are recorded folded to lowercase, so a reader can look one up+-- without case-folding first.+data ResponseMetadata = ResponseMetadata+  { httpStatus :: !Int,+    headers :: ![(Text, Text)]+  }+  deriving stock (Eq, Show, Generic)++-- | The response headers worth recording. Anthropic issues+-- @request-id@; gateways in front of it commonly add @x-request-id@+-- and @cf-ray@. None of these can carry a credential: they are values+-- the server chose, not values baikai sent.+--+-- The order is a preference order as well as an allow-list. A consumer+-- picking one correlation identifier out of a response should take the+-- first of these that is present, so Anthropic's own identifier wins+-- over a gateway's when both are there.+capturedHeaderNames :: [CI SBS.ByteString]+capturedHeaderNames = ["request-id", "x-request-id", "cf-ray"]++-- | Status and allow-listed headers, read straight off the response.+responseMetadata :: HTTP.Response body -> ResponseMetadata+responseMetadata response =+  ResponseMetadata+    { httpStatus = Status.statusCode (HTTP.responseStatus response),+      headers =+        [ (decodeLenient (CI.foldedCase name), decodeLenient value)+        | (name, value) <- HTTP.responseHeaders response,+          name `elem` capturedHeaderNames+        ]+    }+ -- | POST the request to @/v1/messages@ with @stream=true@ and feed each--- decoded SSE event to the callback. A non-2xx response is classified--- from status, @Retry-After@, and body and delivered as one 'Left'.+-- decoded SSE event to the second callback. A non-2xx response is+-- classified from status, @Retry-After@, and body and delivered as one+-- 'Left'.+--+-- The first callback receives the response's 'ResponseMetadata' exactly+-- once, before any event. It is a separate callback rather than a+-- widening of the per-event one because the per-event callback runs+-- once per SSE event — potentially thousands of times per call — and+-- response-level data does not belong on that hot path. claudeSseStream ::   Client.ClientEnv ->   Text ->   Maybe Text ->   Messages.CreateMessage ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->   IO () claudeSseStream env apiKey anthropicVersion req =@@ -49,6 +99,7 @@   Text ->   Maybe Text ->   Aeson.Value ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->   IO () claudeSseStreamValue env apiKey anthropicVersion =@@ -68,9 +119,10 @@   Client.ClientEnv ->   RequestHeaders ->   Aeson.Value ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->   IO ()-claudeSseStreamValueWithHeaders env requestHeaders requestBody onEvent = do+claudeSseStreamValueWithHeaders env requestHeaders requestBody onMetadata onEvent = do   let base = Client.baseUrl env       secure = case Client.baseUrlScheme base of         Client.Http -> False@@ -87,15 +139,23 @@             -- EP-8 wires Options.timeoutMs through this local transport.             HTTP.responseTimeout = HTTP.responseTimeoutNone           }-  HTTP.withResponse request (Client.manager env) (`sseFromResponse` onEvent)+  HTTP.withResponse request (Client.manager env) $ \response ->+    sseFromResponse response onMetadata onEvent  -- | Consume an @http-client@ response as an Anthropic SSE stream.+--+-- 'onMetadata' fires exactly once, before any event, on both the+-- success and the non-2xx path. A failed call's correlation identifier+-- is if anything more valuable than a successful one's, since it is+-- precisely what a provider support request needs. sseFromResponse ::   HTTP.Response HTTP.BodyReader ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->   IO ()-sseFromResponse response onEvent = do+sseFromResponse response onMetadata onEvent = do   let st = HTTP.responseStatus response+  onMetadata (responseMetadata response)   if not (Status.statusIsSuccessful st)     then do       bodyChunks <- HTTP.brConsume (HTTP.responseBody response)

@@ -0,0 +1,397 @@+-- | End-to-end model-call evidence for the @claude -p@ subprocess+-- provider.+--+-- Every case here runs a real child process — a few lines of @sh@+-- written into a temporary directory that print recorded @claude@ JSON+-- and exit. Nothing is stubbed: the argument vector is rendered by+-- 'ClaudeCli.claudeCliCommand', the process is spawned by the real+-- provider, the output is decoded by the real parser, and the evidence+-- is assembled and emitted through the real trace path. No credential+-- and no coding-agent binary is required.+--+-- Assertions go through the encoded JSON rather than through Haskell+-- record accessors, because the JSON is the contract other systems pin+-- against, and it spells its fields in snake_case where a Haskell+-- mirror would silently paper over a rename.+module CliEvidenceSpec (tests) where++import Baikai+import Baikai.Provider.Claude.Cli qualified as ClaudeCli+import Baikai.Trace (withTraceStreamWith)+import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..))+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import System.Directory (getPermissions, setOwnerExecutable, setPermissions)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    -- Named so a documented @--test-options='--pattern CliEvidence'@+    -- actually selects it. A pattern that matches nothing reports+    -- "All 0 tests passed".+    "CliEvidenceSpec: Claude CLI model-call evidence"+    [ successEvidenceTest,+      silentToolTest,+      minimalCollapseTest,+      indistinguishableCallsTest,+      failedRunTest,+      optOutTest+    ]++-- ============================================================+-- The cases+-- ============================================================++successEvidenceTest :: TestTree+successEvidenceTest =+  testCase "a recorded run records what the tool reported" $ do+    outcome <- replay recordedResult baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "succeeded")+    field "run_id" ev @?= Just (String "run-55")+    field "requested_model" ev @?= Just (String "sonnet")++    -- The session identifier the provider used to decode and then throw+    -- away, one line before hardcoding responseId = Nothing.+    field "response_id" ev @?= Just (observedJson "01890000-0000-4000-8000-000000000001")++    -- The model the tool named as having consumed tokens, complete with+    -- its context-window variant marker, and demonstrably not the+    -- model the caller configured.+    field "observed_model" ev @?= Just (observedJson "claude-opus-5[1m]")+    assertBool+      "observed_model must not be the configured model"+      (field "observed_model" ev /= Just (observedJson "sonnet"))++    -- A subprocess cannot carry an HTTP correlation header, and the+    -- tool does not echo its effort setting. Neither is invented.+    field "provider_request_id" ev @?= Just (String "unobserved")+    field "observed_thinking" ev @?= Just (String "unobserved")++    -- Tied to the declaration mechanically: raising declaredStrength+    -- for this transport without the transport reaching it fails here.+    field "strength" ev @?= Just (Aeson.toJSON (declaredStrength AnthropicMessagesCli))+    assertDigest "request_commitment" ev+    assertDigest "request_configuration" ev+    assertObservedDigest "response_commitment" ev++    -- Not zeroUsage: the tool's own counts, with Anthropic's already+    -- disjoint prompt classes carried through unmodified.+    case observedObject "usage" ev of+      Nothing -> assertFailure ("expected an observed usage, got: " <> show (field "usage" ev))+      Just u -> do+        KeyMap.lookup "input_tokens" u @?= Just (Number 2)+        KeyMap.lookup "output_tokens" u @?= Just (Number 6)+        KeyMap.lookup "cache_read_input_tokens" u @?= Nothing+        KeyMap.lookup "cache_read_tokens" u @?= Just (Number 15185)+        KeyMap.lookup "cache_write_tokens" u @?= Just (Number 7455)++    -- A subprocess has no endpoint URL, so the resolved executable+    -- path stands in its place, and the tool's own version is the+    -- implementation version because for this transport the tool is+    -- the implementation.+    case field "endpoint" ev of+      Just (Object o) -> do+        KeyMap.lookup "transport" o @?= Just (String "subprocess")+        KeyMap.lookup "endpoint" o @?= Just (String (Text.pack (outcome ^. #executable)))+        KeyMap.lookup "implementation_version" o @?= Just (String "fake-claude 9.9.9")+      other -> assertFailure ("expected an endpoint object, got: " <> show other)++silentToolTest :: TestTree+silentToolTest =+  testCase "A ZERO EXIT WITH NO IDENTIFIER AND NO MODEL STAYS AT requested_only" $ do+    -- IR-3's rule and the reason this plan exists. A coding-agent CLI+    -- that exits zero has demonstrated that it ran and did not crash.+    -- Subprocess calls almost always exit zero, so encoding that as+    -- corroboration would make the weakest evidence in the system look+    -- like the strongest.+    outcome <- replay silentResult baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "succeeded")+    field "strength" ev @?= Just (String "requested_only")+    field "response_id" ev @?= Just (String "unobserved")+    field "observed_model" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")++minimalCollapseTest :: TestTree+minimalCollapseTest =+  testCase "a minimal request records the --effort low collapse it actually sent" $ do+    -- The description and the argument vector are asserted together so+    -- they cannot drift apart.+    outcome <- replay recordedResult (baseOptions & #thinking .~ Just ThinkingMinimal)+    assertBool+      ("the argument vector must carry --effort low: " <> show (outcome ^. #argv))+      (["--effort", "low"] `isSublistOf` (outcome ^. #argv))+    ev <- oneEvidence (outcome ^. #events)+    case field "thinking" ev of+      Just (Object t) -> do+        KeyMap.lookup "requested" t @?= Just (String "minimal")+        KeyMap.lookup "mode" t @?= Just (String "flag")+        KeyMap.lookup "effort_text" t @?= Just (String "low")+        KeyMap.lookup "wire_field" t @?= Just (String "--effort")+        KeyMap.lookup "budget_tokens" t @?= Just Null+        KeyMap.lookup "adjustments" t+          @?= Just+            ( Array+                ( Vector.singleton+                    ( Object+                        ( KeyMap.fromList+                            [ ("kind", String "effort_clamped"),+                              ("requested", String "minimal"),+                              ("wire", String "low")+                            ]+                        )+                    )+                )+            )+      other -> assertFailure ("expected a thinking translation, got: " <> show other)++indistinguishableCallsTest :: TestTree+indistinguishableCallsTest =+  testCase "TWO CALLS THE TOOL CANNOT TELL APART PRODUCE EVIDENCE THAT CAN" $ do+    -- This is the case that demonstrates why the record exists rather+    -- than merely that a field is populated. A caller asking for+    -- minimal and a caller asking for low send byte-identical command+    -- lines, so nothing downstream of the argument vector could ever+    -- recover the difference — including the request commitment digest,+    -- which is computed over that vector. The translation is the only+    -- place the collapse survives.+    withFakeClaude recordedResult $ \runOnce -> do+      lowRun <- runOnce (baseOptions & #thinking .~ Just ThinkingLow)+      minimalRun <- runOnce (baseOptions & #thinking .~ Just ThinkingMinimal)+      minimalRun ^. #argv @?= lowRun ^. #argv++      lowEv <- oneEvidence (lowRun ^. #events)+      minimalEv <- oneEvidence (minimalRun ^. #events)+      field "request_commitment" minimalEv @?= field "request_commitment" lowEv++      requestedLevel lowEv @?= Just (String "low")+      requestedLevel minimalEv @?= Just (String "minimal")+      adjustmentCount lowEv @?= Just 0+      adjustmentCount minimalEv @?= Just 1++failedRunTest :: TestTree+failedRunTest =+  testCase "a tool that exits nonzero records the failure and commits to no response" $ do+    outcome <- replay Nothing baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "failed")+    case field "error_info" ev of+      Just (Object o) ->+        assertBool+          ("expected a populated error_info, got: " <> show o)+          (KeyMap.member "message" o)+      other -> assertFailure ("expected a populated error_info, got: " <> show other)+    -- No parseable result means nothing to commit to. A digest of an+    -- empty envelope would be a real-looking value standing for a+    -- response that never arrived.+    field "response_commitment" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")+    field "strength" ev @?= Just (String "requested_only")++optOutTest :: TestTree+optOutTest =+  testCase "a call that asked for no evidence emits none" $ do+    outcome <- replay recordedResult emptyOptions+    [e | e@CallEvidence {} <- outcome ^. #events] @?= []+    length [e | e@CallStarted {} <- outcome ^. #events] @?= 1+    length [e | e@CallFinished {} <- outcome ^. #events] @?= 1++-- ============================================================+-- Replay harness+-- ============================================================++-- | What one replayed call produced.+data Replay = Replay+  { events :: ![TraceEvent],+    -- | The argument vector the fake executable actually received.+    argv :: ![Text],+    -- | The path the fake executable was written to.+    executable :: !FilePath+  }+  deriving stock (Generic)++-- | Run one call against a fake @claude@ that prints the given JSON on+-- standard output.+--+-- 'Nothing' makes the fake exit nonzero with a message on standard+-- error, which is how a failed run is replayed.+replay :: Maybe Text -> Options -> IO Replay+replay stdoutJson opts = withFakeClaude stdoutJson ($ opts)++-- | Write one fake @claude@ and hand back a function that runs calls+-- against it.+--+-- Two calls compared against each other must go through the __same__+-- fake, because the argument vector the request commitment digests+-- begins with the executable's path — so two fakes in two temporary+-- directories would differ for a reason that has nothing to do with+-- what the test is about.+withFakeClaude :: Maybe Text -> ((Options -> IO Replay) -> IO a) -> IO a+withFakeClaude stdoutJson k =+  withSystemTempDirectory "baikai-claude-cli-evidence" $ \dir -> do+    let argvPath = dir </> "argv"+    exe <- writeFakeExecutable dir "claude" (fakeClaude argvPath stdoutJson)+    k $ \opts -> do+      reg <- newProviderRegistry+      registerApiProviderWith+        reg+        ( ClaudeCli.claudeCliProvider+            ClaudeCli.defaultClaudeCliConfig {ClaudeCli.executable = exe}+        )+      (ref, sink) <- memorySink+      _ <- Stream.fold Fold.drain (withTraceStreamWith reg sink testModel testContext opts)+      recorded <- reverse <$> readTVarIO ref+      received <- Text.lines <$> TextIO.readFile argvPath+      pure Replay {events = recorded, argv = received, executable = exe}++-- | A fake @claude@ in a few lines of @sh@.+--+-- It answers @--version@ before recording anything, exactly as the real+-- tool does. That is not decoration: the evidence path probes the+-- executable's version with a second invocation, and a fake that+-- recorded that invocation's argument vector would overwrite the one+-- the test is about to assert on.+fakeClaude :: FilePath -> Maybe Text -> String+fakeClaude argvPath stdoutJson =+  unlines+    ( [ "#!/bin/sh",+        "if [ \"$1\" = \"--version\" ]; then echo 'fake-claude 9.9.9'; exit 0; fi",+        "printf '%s\\n' \"$@\" > '" <> argvPath <> "'"+      ]+        <> case stdoutJson of+          Nothing -> ["echo 'the tool refused' >&2", "exit 3"]+          Just body -> ["cat <<'BAIKAI_FIXTURE'", Text.unpack body, "BAIKAI_FIXTURE"]+    )++writeFakeExecutable :: FilePath -> String -> String -> IO FilePath+writeFakeExecutable dir name body = do+  let path = dir </> name+  writeFile path body+  perms <- getPermissions path+  setPermissions path (setOwnerExecutable True perms)+  pure path++memorySink :: IO (TVar [TraceEvent], TraceSink)+memorySink = do+  ref <- newTVarIO []+  let step () e = atomically (modifyTVar' ref (e :))+  pure (ref, TraceSink (Fold.foldlM' step (pure ())))++-- ============================================================+-- Fixtures+-- ============================================================++testModel :: Model+testModel =+  emptyModel+    & #modelId .~ "sonnet"+    & #api .~ AnthropicMessagesCli+    & #provider .~ "anthropic"++testContext :: Context+testContext = emptyContext & #messages .~ Vector.singleton (user "PROMPT-BODY-MARKER")++baseOptions :: Options+baseOptions = emptyOptions & #evidence .~ Just (evidenceRequest "run-55")++-- | The event array @claude 2.1.222@ emits, trimmed to the fields the+-- provider reads and with the identifiers scrubbed.+recordedResult :: Maybe Text+recordedResult =+  Just+    "[{\"type\":\"system\",\"subtype\":\"init\",\+    \\"session_id\":\"01890000-0000-4000-8000-000000000001\"},\+    \{\"type\":\"result\",\"subtype\":\"success\",\"is_error\":false,\"result\":\"ok\",\+    \\"session_id\":\"01890000-0000-4000-8000-000000000001\",\+    \\"total_cost_usd\":0.0823025,\+    \\"usage\":{\"input_tokens\":2,\"output_tokens\":6,\+    \\"cache_read_input_tokens\":15185,\"cache_creation_input_tokens\":7455},\+    \\"modelUsage\":{\"claude-opus-5[1m]\":{\"inputTokens\":2,\"outputTokens\":6}}}]"++-- | A run that succeeded and said nothing about itself.+silentResult :: Maybe Text+silentResult = Just "[{\"type\":\"result\",\"is_error\":false,\"result\":\"ok\"}]"++-- ============================================================+-- Assertions on the encoded record+-- ============================================================++oneEvidence :: [TraceEvent] -> IO ModelCallEvidence+oneEvidence recorded = case [ev | CallEvidence {evidence = ev} <- recorded] of+  [ev] -> pure ev+  other ->+    assertFailure+      ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show recorded)++field :: Text -> ModelCallEvidence -> Maybe Value+field k ev = case Aeson.toJSON ev of+  Object o -> KeyMap.lookup (Key.fromText k) o+  _ -> Nothing++-- | How 'Baikai.Evidence.Observed' encodes a present value.+observedJson :: Text -> Value+observedJson v = Object (KeyMap.singleton "observed" (String v))++observedObject :: Text -> ModelCallEvidence -> Maybe (KeyMap.KeyMap Value)+observedObject k ev = case field k ev of+  Just (Object o) -> case KeyMap.lookup "observed" o of+    Just (Object inner) -> Just inner+    _ -> Nothing+  _ -> Nothing++requestedLevel :: ModelCallEvidence -> Maybe Value+requestedLevel ev = case field "thinking" ev of+  Just (Object t) -> KeyMap.lookup "requested" t+  _ -> Nothing++adjustmentCount :: ModelCallEvidence -> Maybe Int+adjustmentCount ev = case field "thinking" ev of+  Just (Object t) -> case KeyMap.lookup "adjustments" t of+    Just (Array a) -> Just (Vector.length a)+    _ -> Nothing+  _ -> Nothing++assertDigest :: Text -> ModelCallEvidence -> IO ()+assertDigest k ev = case field k ev of+  Just (String d) -> assertSha256 k d+  other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other)++assertObservedDigest :: Text -> ModelCallEvidence -> IO ()+assertObservedDigest k ev = case field k ev of+  Just (Object o) -> case KeyMap.lookup "observed" o of+    Just (String d) -> assertSha256 k d+    other -> assertFailure (Text.unpack k <> " not a digest: " <> show other)+  other -> assertFailure ("expected an observed " <> Text.unpack k <> ", got: " <> show other)++assertSha256 :: Text -> Text -> IO ()+assertSha256 k d =+  assertBool+    (Text.unpack k <> " must be a sha256 digest, got: " <> show d)+    ("sha256:" `Text.isPrefixOf` d && Text.length d == 71)++isSublistOf :: (Eq a) => [a] -> [a] -> Bool+isSublistOf needle haystack =+  any (\suffix -> needle == take (length needle) suffix) (suffixes haystack)+  where+    suffixes xs =+      xs : case xs of+        [] -> []+        (_ : rest) -> suffixes rest

@@ -0,0 +1,310 @@+-- | End-to-end model-call evidence for the Anthropic Messages provider.+--+-- Every case here replays a recorded HTTP response through the real+-- adapter and reads the evidence back out of a trace sink. Nothing is+-- stubbed but the socket: the request is built by @mapRequest@, the+-- response is decoded by @sseFromResponse@, the headers are captured by+-- the real allow-list, and the record is assembled and emitted by the+-- real trace path.+--+-- Assertions go through the encoded JSON rather than through Haskell+-- record accessors, because the JSON is the contract other systems pin+-- against, and it spells its fields in snake_case where a Haskell+-- mirror would silently paper over a rename.+module EvidenceSpec (tests) where++import Baikai+import Baikai.Models.Generated (anthropic_claude_haiku_4_5)+import Baikai.Provider.Claude.Api (SseDriver, claudeMessagesStreamWith)+import Baikai.Provider.Claude.Internal.Request (describeThinkingFor)+import Baikai.Provider.Claude.Sse (sseFromResponse)+import Baikai.Trace (withTraceStreamWith)+import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..))+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    -- Named so this plan's documented+    -- @--test-options='--pattern Evidence'@ actually selects it. A+    -- pattern that matches nothing reports "All 0 tests passed".+    "EvidenceSpec: Anthropic model-call evidence"+    [ successEvidenceTest,+      rateLimitEvidenceTest,+      thinkingEvidenceTest,+      optOutTest+    ]++-- ============================================================+-- The cases+-- ============================================================++successEvidenceTest :: TestTree+successEvidenceTest =+  testCase "a replayed successful call records what Anthropic reported" $ do+    ev <- oneEvidence =<< replay 200 successHeaders successBody baseOptions+    field "status" ev @?= Just (String "succeeded")+    field "error_info" ev @?= Just Null+    field "run_id" ev @?= Just (String "run-53")++    -- The heart of it: requested and observed are different values, and+    -- the observed one came from the provider's own message_start.+    field "requested_model" ev @?= Just (String (anthropic_claude_haiku_4_5 ^. #modelId))+    field "observed_model" ev @?= Just (observedJson "claude-haiku-4-5-20990101-server-side")+    assertBool+      "observed_model must not be the configured model"+      (field "observed_model" ev /= Just (observedJson (anthropic_claude_haiku_4_5 ^. #modelId)))++    field "provider_request_id" ev @?= Just (observedJson "req_success_1")+    field "response_id" ev @?= Just (observedJson "msg_observed")+    -- Tied to the declaration mechanically: raising declaredStrength+    -- for this transport without the transport reaching it fails here.+    field "strength" ev @?= Just (Aeson.toJSON (declaredStrength AnthropicMessages))++    -- Anthropic never echoes the thinking configuration it applied, so+    -- this transport cannot reach fully_observed and must not pretend+    -- a reasoning-token count is such an echo.+    field "observed_thinking" ev @?= Just (String "unobserved")++    assertDigest "request_commitment" ev+    assertDigest "request_configuration" ev+    case field "response_commitment" ev of+      Just (Object o) -> case KeyMap.lookup "observed" o of+        Just (String d) -> assertSha256 "response_commitment" d+        other -> assertFailure ("response_commitment not a digest: " <> show other)+      other -> assertFailure ("expected an observed response_commitment, got: " <> show other)++    -- Usage is Observed because Anthropic reported it, and carries the+    -- fixture's counts rather than the assembler's initial zeroes.+    case field "usage" ev of+      Just (Object o) -> case KeyMap.lookup "observed" o of+        Just (Object u) -> do+          KeyMap.lookup "input_tokens" u @?= Just (Number 11)+          KeyMap.lookup "output_tokens" u @?= Just (Number 5)+        other -> assertFailure ("usage.observed not an object: " <> show other)+      other -> assertFailure ("expected an observed usage, got: " <> show other)++    -- The endpoint names this package's own version, read from the+    -- cabal-generated module.+    case field "endpoint" ev of+      Just (Object o) -> do+        KeyMap.lookup "transport" o @?= Just (String "http_api")+        case KeyMap.lookup "implementation_version" o of+          Just (String v) ->+            assertBool "implementation_version must not be empty" (not (Text.null v))+          other -> assertFailure ("expected an implementation_version, got: " <> show other)+      other -> assertFailure ("expected an endpoint object, got: " <> show other)++rateLimitEvidenceTest :: TestTree+rateLimitEvidenceTest =+  testCase "a replayed 429 records the correlation id and observes nothing else" $ do+    ev <-+      oneEvidence+        =<< replay+          429+          [("request-id", "req_rate_limited"), ("Retry-After", "7")]+          ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"]+          baseOptions+    field "status" ev @?= Just (String "failed")+    case field "error_info" ev of+      Just (Object o) ->+        assertBool+          ("expected the rate-limit message, got: " <> show o)+          (KeyMap.lookup "message" o /= Nothing)+      other -> assertFailure ("expected a populated error_info, got: " <> show other)++    -- The header is present on errors too, and it is the single most+    -- useful thing to have when opening a provider support request.+    field "provider_request_id" ev @?= Just (observedJson "req_rate_limited")++    -- Absent metadata stays absent. None of these is backfilled.+    field "observed_model" ev @?= Just (String "unobserved")+    field "response_id" ev @?= Just (String "unobserved")+    field "response_commitment" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")+    field "strength" ev @?= Just (String "correlated")++thinkingEvidenceTest :: TestTree+thinkingEvidenceTest =+  testCase "the evidence carries the thinking translation the request actually used" $ do+    ev <-+      oneEvidence+        =<< replay+          200+          successHeaders+          successBody+          (baseOptions & #thinking .~ Just ThinkingMinimal)+    case field "thinking" ev of+      Just (Object t) -> do+        KeyMap.lookup "requested" t @?= Just (String "minimal")+        -- haiku-4-5 is a budget-style model, so the level is expressed+        -- exactly and nothing is adjusted.+        KeyMap.lookup "mode" t @?= Just (String "budget")+        KeyMap.lookup "budget_tokens" t @?= Just (Number 1024)+        KeyMap.lookup "effort_text" t @?= Just Null+        KeyMap.lookup "wire_field" t @?= Just (String "thinking")+        KeyMap.lookup "adjustments" t @?= Just (Array Vector.empty)+      other -> assertFailure ("expected a thinking translation, got: " <> show other)++optOutTest :: TestTree+optOutTest =+  testCase "a call that asked for no evidence emits none" $ do+    events <- replay 200 successHeaders successBody emptyCallOptions+    [e | e@CallEvidence {} <- events] @?= []+    -- The call itself still succeeded and still traced normally.+    length [e | e@CallStarted {} <- events] @?= 1+    length [e | e@CallFinished {} <- events] @?= 1++-- ============================================================+-- Replay harness+-- ============================================================++-- | Run one recorded response through the real adapter and the real+-- trace path, and return every trace event it produced.+replay :: Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [TraceEvent]+replay status headers chunks opts = do+  reg <- newProviderRegistry+  let driver = replayDriver status headers chunks+      provider =+        ApiProvider+          { apiTag = AnthropicMessages,+            stream = claudeMessagesStreamWith driver,+            complete = streamingComplete (claudeMessagesStreamWith driver),+            describeThinking = describeThinkingFor+          }+  registerApiProviderWith reg provider+  (ref, sink) <- memorySink+  _ <-+    Stream.fold+      Fold.drain+      (withTraceStreamWith reg sink testModel emptyContext opts)+  reverse <$> readTVarIO ref++-- | A transport driver that serves a recorded response instead of+-- opening a socket.+--+-- It goes through 'sseFromResponse', so the status classification,+-- header allow-list, and SSE frame decoding under test are the ones+-- production uses. Only 'HTTP.withResponse' is replaced.+replayDriver :: Int -> [(ByteString, ByteString)] -> [ByteString] -> SseDriver+replayDriver status headers chunks _call onMetadata onEvent = do+  resp <- mkResponse status headers chunks+  sseFromResponse resp onMetadata onEvent++mkResponse ::+  Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader)+mkResponse status headers chunks = do+  ref <- newIORef chunks+  let bodyReader = do+        remaining <- readIORef ref+        case remaining of+          [] -> pure ""+          (x : xs) -> writeIORef ref xs >> pure x+  pure+    HTTP.Response+      { HTTP.responseStatus = mkStatus status "",+        HTTP.responseVersion = http11,+        HTTP.responseHeaders = [(CI.mk k, v) | (k, v) <- headers],+        HTTP.responseBody = bodyReader,+        HTTP.responseCookieJar = HTTP.createCookieJar [],+        HTTP.responseClose' = HTTP.ResponseClose (pure ()),+        HTTP.responseOriginalRequest = HTTP.defaultRequest,+        HTTP.responseEarlyHints = []+      }++memorySink :: IO (TVar [TraceEvent], TraceSink)+memorySink = do+  ref <- newTVarIO []+  let step () e = atomically (modifyTVar' ref (e :))+  pure (ref, TraceSink (Fold.foldlM' step (pure ())))++-- ============================================================+-- Fixtures+-- ============================================================++testModel :: Model+testModel =+  anthropic_claude_haiku_4_5+    & #api .~ AnthropicMessages+    & #baseUrl .~ "https://api.anthropic.com"++-- | A literal key, so 'prepareCall' resolves one without reading the+-- environment. It never reaches the replayed response.+emptyCallOptions :: Options+emptyCallOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key")++baseOptions :: Options+baseOptions = emptyCallOptions & #evidence .~ Just (evidenceRequest "run-53")++successHeaders :: [(ByteString, ByteString)]+successHeaders = [("request-id", "req_success_1")]++-- | A complete successful stream whose reported model is deliberately+-- not any model in the catalog, so it cannot be confused with a+-- configured one.+successBody :: [ByteString]+successBody =+  [ "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_observed\",\"type\":\"message\",",+    "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-haiku-4-5-20990101-server-side\",",+    "\"stop_reason\":null,\"stop_sequence\":null,",+    "\"usage\":{\"input_tokens\":11,\"output_tokens\":0}}}\n\n",+    "data: {\"type\":\"content_block_start\",\"index\":0,",+    "\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n",+    "data: {\"type\":\"content_block_delta\",\"index\":0,",+    "\"delta\":{\"type\":\"text_delta\",\"text\":\"pong\"}}\n\n",+    "data: {\"type\":\"content_block_stop\",\"index\":0}\n\n",+    "data: {\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},",+    "\"usage\":{\"output_tokens\":5}}\n\n",+    "data: {\"type\":\"message_stop\"}\n\n"+  ]++-- ============================================================+-- Assertions on the encoded record+-- ============================================================++oneEvidence :: [TraceEvent] -> IO ModelCallEvidence+oneEvidence events = case [ev | CallEvidence {evidence = ev} <- events] of+  [ev] -> pure ev+  other ->+    assertFailure+      ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show events)++field :: Text -> ModelCallEvidence -> Maybe Value+field k ev = case Aeson.toJSON ev of+  Object o -> KeyMap.lookup (Key.fromText k) o+  _ -> Nothing++-- | How 'Baikai.Evidence.Observed' encodes a present value.+observedJson :: Text -> Value+observedJson v = Object (KeyMap.singleton "observed" (String v))++assertDigest :: Text -> ModelCallEvidence -> IO ()+assertDigest k ev = case field k ev of+  Just (String d) -> assertSha256 k d+  other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other)++assertSha256 :: Text -> Text -> IO ()+assertSha256 k d =+  assertBool+    (Text.unpack k <> " must be a sha256 digest, got: " <> show d)+    ("sha256:" `Text.isPrefixOf` d && Text.length d == 71)

@@ -1,11 +1,24 @@ module Main (main) where  import Baikai+import Baikai.Agent+  ( AgentCapability (..),+    AgentCommand,+    AgentPromptTransport (..),+    AgentProvider (..),+    AgentRenderError (..),+    AgentRunRequest,+    agentRunRequest,+    agentSafety,+    renderAgentRenderError,+  )+import Baikai.Provider.Claude.Agent qualified as ClaudeAgent import Baikai.Provider.Claude.Api import Baikai.Provider.Claude.Cli qualified as ClaudeCli import Baikai.Provider.Claude.Interactive-import Baikai.Provider.Claude.Internal.Request (mapRequest)+import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) import Claude.V1.Messages qualified as Messages+import CliEvidenceSpec qualified import Control.Exception (bracket) import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson@@ -14,6 +27,7 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import ErrorClassSpec qualified+import EvidenceSpec qualified import ShapeSpec qualified import SseSpec qualified import Streamly.Data.Stream qualified as Stream@@ -33,6 +47,18 @@       "Baikai.Provider.Claude"       [ commandRenderingTest,         effortRenderingTests,+        safetyRefusalTest,+        safetyStillRendersTest,+        agentCommandRenderingTest,+        agentCapabilityRenderingTests,+        agentEffortRenderingTests,+        agentThinkingTranslationTests,+        strictEvidenceTests,+        agentPromptTransportTest,+        agentBlankModelTest,+        agentSessionPersistenceTest,+        agentProviderGuardTest,+        agentKeiroFixtureTest,         batchCommandRenderingTest,         batchEffortRenderingTests,         stderrFloodTest,@@ -42,7 +68,9 @@         cliMissingBinaryTest,         responseFormatMappingTest,         optionsMappingTest,+        CliEvidenceSpec.tests,         ErrorClassSpec.tests,+        EvidenceSpec.tests,         ShapeSpec.tests,         SseSpec.tests,         ThinkingSpec.tests,@@ -52,7 +80,7 @@ -- | A 'JsonSchema' on 'Options.responseFormat' maps onto Anthropic's -- native @output_config@, forwarding the schema 'Value' verbatim via -- 'Messages.jsonSchemaConfig'. Pure: 'mapRequest' is--- 'Either Text Messages.CreateMessage'.+-- 'Either Text (Messages.CreateMessage, ThinkingTranslation)'. responseFormatMappingTest :: TestTree responseFormatMappingTest =   testCase "responseFormat JsonSchema maps onto Anthropic output_config" $ do@@ -79,7 +107,7 @@               .~ Just (JsonSchema {name = "person", schema = personSchema, strict = True})     case mapRequest model ctx opts of       Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)-      Right req ->+      Right (req, _) ->         Messages.output_config req           @?= Just (Messages.jsonSchemaConfig personSchema) @@ -100,7 +128,7 @@             & #presencePenalty .~ Just 0.3     case mapRequest model emptyContext opts of       Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)-      Right req -> do+      Right (req, _) -> do         Messages.top_p req @?= Just 0.9         Messages.stop_sequences req @?= Just (Vector.fromList ["END", "STOP"]) @@ -121,24 +149,25 @@             & #safety .~ ClaudeAllowedTools ["Read", "Bash(git status)"]             & #extraArgs .~ ["--permission-mode", "plan"]     claudeInteractiveCommand cfg req-      @?= ( "/bin/claude",-            [ "--model",-              "sonnet",-              "--system-prompt",-              "Be terse.",-              "--add-dir",-              "/work/shared",-              "--add-dir",-              "/work/docs",-              "--allowedTools",-              "Read,Bash(git status)",-              "--debug",-              "--permission-mode",-              "plan",-              "--",-              "inspect the repo"-            ]-          )+      @?= Right+        ( "/bin/claude",+          [ "--model",+            "sonnet",+            "--system-prompt",+            "Be terse.",+            "--add-dir",+            "/work/shared",+            "--add-dir",+            "/work/docs",+            "--allowedTools",+            "Read,Bash(git status)",+            "--debug",+            "--permission-mode",+            "plan",+            "--",+            "inspect the repo"+          ]+        )  effortRenderingTests :: TestTree effortRenderingTests =@@ -147,7 +176,7 @@     [ testCase name $ do         let req = interactiveLaunchRequest "prompt" & #effort .~ Just level         claudeInteractiveCommand defaultClaudeInteractiveConfig req-          @?= ("claude", ["--effort", expected, "--", "prompt"])+          @?= Right ("claude", ["--effort", expected, "--", "prompt"])     | (name, level, expected) <-         [ ("minimal as low", ThinkingMinimal, "low"),           ("low", ThinkingLow, "low"),@@ -157,6 +186,374 @@           ("max", ThinkingMax, "max")         ]     ]++safetyRefusalTest :: TestTree+safetyRefusalTest =+  testCase "refuses a Codex sandbox policy instead of launching unrestricted" $ do+    let req =+          interactiveLaunchRequest "inspect the repo"+            & #safety .~ CodexSandbox CodexReadOnly CodexApprovalNever+    case claudeInteractiveCommand defaultClaudeInteractiveConfig req of+      Right rendered -> assertFailure ("expected refusal, rendered: " <> show rendered)+      Left err -> do+        case err of+          SafetyNotExpressible p _ -> p @?= AgentClaude+          other -> assertFailure ("expected SafetyNotExpressible, got: " <> show other)+        let message = renderAgentRenderError err+        assertBool "names the provider" ("Claude" `Text.isInfixOf` message)+        assertBool "names the rejected sandbox mode" ("read-only" `Text.isInfixOf` message)+        assertBool "names the rejected approval policy" ("never" `Text.isInfixOf` message)+        assertBool "suggests an alternative" ("ClaudeAllowedTools" `Text.isInfixOf` message)++-- | The fix refuses only what Claude cannot express. An allow-list is+-- expressible and must still render, and an empty allow-list restricts+-- nothing so it renders no safety flag rather than being refused.+safetyStillRendersTest :: TestTree+safetyStillRendersTest =+  testGroup+    "still renders every safety policy Claude can express"+    [ testCase "a non-empty allow-list" $ do+        let req =+              interactiveLaunchRequest "inspect"+                & #safety .~ ClaudeAllowedTools ["Read", "Grep"]+        fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req)+          @?= Right ["--allowedTools", "Read,Grep", "--", "inspect"],+      testCase "an empty allow-list renders no safety flag" $ do+        let req = interactiveLaunchRequest "inspect" & #safety .~ ClaudeAllowedTools []+        fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req)+          @?= Right ["--", "inspect"],+      testCase "DefaultSafety renders no safety flag" $ do+        let req = interactiveLaunchRequest "inspect" & #safety .~ DefaultSafety+        fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req)+          @?= Right ["--", "inspect"]+    ]++-- | Render an unattended command or fail the test with the refusal's+-- own message.+renderedAgentCommand ::+  ClaudeAgent.ClaudeAgentConfig -> AgentRunRequest -> IO AgentCommand+renderedAgentCommand cfg req = fst <$> renderedAgentPair cfg req++-- | The command and the reasoning-effort translation the renderer+-- produced together.+renderedAgentPair ::+  ClaudeAgent.ClaudeAgentConfig ->+  AgentRunRequest ->+  IO (AgentCommand, ThinkingTranslation)+renderedAgentPair cfg req =+  either+    (assertFailure . Text.unpack . renderAgentRenderError)+    pure+    (ClaudeAgent.claudeAgentCommand cfg req)++agentCommandRenderingTest :: TestTree+agentCommandRenderingTest =+  testCase "unattended claude argv renders every structured flag in a fixed order" $ do+    let cfg =+          ClaudeAgent.defaultClaudeAgentConfig+            & #executable .~ "/bin/claude"+            & #extraArgs .~ ["--debug"]+        req =+          agentRunRequest AgentClaude "/work/project" "reconcile the grammar"+            & #modelId .~ Just "sonnet"+            & #effort .~ Just ThinkingHigh+            & #extraDirs .~ ["/work/shared", "/work/docs"]+            & #safety .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read", "Write"])+            & #safety . #providerArgs .~ ["--betas", "context-1m"]+    cmd <- renderedAgentCommand cfg req+    cmd ^. #executable @?= "/bin/claude"+    cmd ^. #arguments+      @?= [ "-p",+            "--no-session-persistence",+            "--model",+            "sonnet",+            "--effort",+            "high",+            "--permission-mode",+            "acceptEdits",+            "--allowedTools",+            "Read,Write",+            "--add-dir",+            "/work/shared",+            "--add-dir",+            "/work/docs",+            "--debug",+            "--betas",+            "context-1m"+          ]+    cmd ^. #promptTransport @?= PromptOnStdin+    cmd ^. #promptText @?= "reconcile the grammar"++agentCapabilityRenderingTests :: TestTree+agentCapabilityRenderingTests =+  testGroup+    "unattended claude argv maps every capability onto a permission mode"+    [ testCase name $ do+        let req =+              agentRunRequest AgentClaude "/work/project" "prompt"+                & #safety .~ agentSafety cap+        cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+        cmd ^. #arguments+          @?= ["-p", "--no-session-persistence", "--permission-mode", expected]+    | (name, cap, expected) <-+        [ ("read-only as plan", AgentReadOnly, "plan"),+          ("edit-workspace as acceptEdits", AgentEditWorkspace, "acceptEdits"),+          ("full-access as bypassPermissions", AgentFullAccess, "bypassPermissions")+        ]+    ]++-- | Claude's @--effort@ has no @minimal@ value, so the lowest level+-- maps up to @low@. Codex passes all six through unchanged; pinning+-- both sides stops someone later \"unifying\" them.+agentEffortRenderingTests :: TestTree+agentEffortRenderingTests =+  testGroup+    "unattended claude argv clamps minimal effort up to low"+    [ testCase name $ do+        let req =+              agentRunRequest AgentClaude "/work/project" "prompt"+                & #effort .~ Just level+        cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+        cmd ^. #arguments+          @?= [ "-p",+                "--no-session-persistence",+                "--effort",+                expected,+                "--permission-mode",+                "plan"+              ]+    | (name, level, expected) <-+        [ ("minimal as low", ThinkingMinimal, "low"),+          ("low", ThinkingLow, "low"),+          ("medium", ThinkingMedium, "medium"),+          ("high", ThinkingHigh, "high"),+          ("xhigh", ThinkingXHigh, "xhigh"),+          ("max", ThinkingMax, "max")+        ]+    ]++-- | The prompt travels on standard input, so a prompt that begins with+-- a dash cannot be parsed as a flag and cannot be swallowed by a+-- preceding variadic flag. Dash-leading directories still appear as+-- ordinary arguments following their own flag.+agentPromptTransportTest :: TestTree+agentPromptTransportTest =+  testCase "unattended claude argv never contains the prompt, even a dash-leading one" $ do+    let dashPrompt = "-rm -rf /"+        req =+          agentRunRequest AgentClaude "-/work/dashdir" dashPrompt+            & #extraDirs .~ ["-/work/dashshared"]+            & #safety .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read"])+    cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+    assertBool+      ("prompt leaked into argv: " <> show (cmd ^. #arguments))+      (Text.unpack dashPrompt `notElem` cmd ^. #arguments)+    cmd ^. #promptText @?= dashPrompt+    cmd ^. #promptTransport @?= PromptOnStdin+    cmd ^. #arguments+      @?= [ "-p",+            "--no-session-persistence",+            "--permission-mode",+            "acceptEdits",+            "--allowedTools",+            "Read",+            "--add-dir",+            "-/work/dashshared"+          ]++agentBlankModelTest :: TestTree+agentBlankModelTest =+  testCase "unattended claude argv omits --model for a blank model value" $ do+    let req =+          agentRunRequest AgentClaude "/work/project" "prompt"+            & #modelId .~ Just "   "+    cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+    cmd ^. #arguments+      @?= ["-p", "--no-session-persistence", "--permission-mode", "plan"]++agentSessionPersistenceTest :: TestTree+agentSessionPersistenceTest =+  testCase "unattended claude argv persists a session only when asked" $ do+    let req = agentRunRequest AgentClaude "/work/project" "prompt"+        persisting = ClaudeAgent.defaultClaudeAgentConfig & #persistSession .~ True+    byDefault <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+    byDefault ^. #arguments+      @?= ["-p", "--no-session-persistence", "--permission-mode", "plan"]+    persisted <- renderedAgentCommand persisting req+    persisted ^. #arguments @?= ["-p", "--permission-mode", "plan"]++-- | The unattended renderer describes what it did with the caller's+-- reasoning-effort request, and the description agrees with the argument+-- vector it produced.+--+-- Asserted together on purpose: the whole value of the translation is+-- that it survives a collapse the command line cannot express, and two+-- separate tests could drift apart without either failing.+agentThinkingTranslationTests :: TestTree+agentThinkingTranslationTests =+  testGroup+    "the unattended claude renderer records what --effort actually received"+    ( testCase+        "no effort requested is not a downgrade"+        ( do+            (cmd, translation) <- renderedAgentPair ClaudeAgent.defaultClaudeAgentConfig (effortRequest Nothing)+            assertBool+              ("no --effort flag is rendered: " <> show (cmd ^. #arguments))+              ("--effort" `notElem` (cmd ^. #arguments))+            translation @?= noThinkingRequested+        )+        : [ testCase (Text.unpack (renderThinkingLevel level)) $ do+              (cmd, translation) <-+                renderedAgentPair ClaudeAgent.defaultClaudeAgentConfig (effortRequest (Just level))+              assertBool+                ("--effort " <> Text.unpack wire <> " in " <> show (cmd ^. #arguments))+                (["--effort", Text.unpack wire] `isConsecutiveIn` (cmd ^. #arguments))+              translation+                @?= ThinkingTranslation+                  { requested = Just level,+                    mode = ThinkingModeFlag,+                    effortText = Just wire,+                    budgetTokens = Nothing,+                    wireField = Just "--effort",+                    adjustments = expected+                  }+          | (level, wire, expected) <-+              [ -- claude's --effort has no minimal, so the lowest level+                -- collapses and a run at minimal is wire-identical to a+                -- run at low.+                (ThinkingMinimal, "low", [EffortClamped ThinkingMinimal "low"]),+                (ThinkingLow, "low", []),+                (ThinkingMedium, "medium", []),+                (ThinkingHigh, "high", []),+                (ThinkingXHigh, "xhigh", []),+                (ThinkingMax, "max", [])+              ]+          ]+    )+  where+    effortRequest level =+      agentRunRequest AgentClaude "/work/project" "prompt" & #effort .~ level++-- | Whether the needle appears as consecutive elements of the haystack.+isConsecutiveIn :: (Eq a) => [a] -> [a] -> Bool+isConsecutiveIn needle haystack =+  any (\suffix -> needle == take (length needle) suffix) (suffixes haystack)+  where+    suffixes xs =+      xs : case xs of+        [] -> []+        (_ : rest) -> suffixes rest++-- | The pre-dispatch strictness gate, fed by this package's __real__+-- translation functions rather than by hand-built adjustments.+--+-- The generic gate is exhaustively covered in+-- @baikai/test/StrictEvidenceSpec.hs@; what only this package can prove+-- is that its own downgrade sites actually reach the gate.+strictEvidenceTests :: TestTree+strictEvidenceTests =+  testGroup+    "strict evidence refuses this provider's real downgrades"+    [ testCase "a model that does not advertise reasoning is refused" $ do+        let m =+              emptyModel+                & #modelId .~ "claude-no-reasoning"+                & #api .~ AnthropicMessages+                & #reasoning .~ False+            opts = emptyOptions & #thinking .~ Just ThinkingHigh+        expectDowngrade+          (ThinkingDroppedUnsupportedModel ThinkingHigh)+          (describeThinkingFor m opts),+      testCase "A THINKING BUDGET THAT WILL NOT FIT max_tokens IS REFUSED" $ do+        -- The least discoverable downgrade in baikai: a caller lowered+        -- maxTokens and silently lost thinking on a reasoning model.+        let m =+              emptyModel+                & #modelId .~ "claude-reasoning"+                & #api .~ AnthropicMessages+                & #reasoning .~ True+                & #maxOutputTokens .~ 8192+            opts =+              emptyOptions+                & #thinking .~ Just ThinkingMax+                & #maxTokens .~ Just 128+        case describeThinkingFor m opts ^. #adjustments of+          [ThinkingDroppedBudgetExceeded lvl _ _] -> lvl @?= ThinkingMax+          other -> assertFailure ("expected a budget drop, got: " <> show other)+        assertBool+          "the gate must refuse it"+          (not (null (checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) AnthropicMessages (describeThinkingFor m opts)))),+      testCase "the claude CLI's minimal collapse is refused" $+        expectDowngrade+          (EffortClamped ThinkingMinimal "low")+          (ClaudeCli.claudeCliThinking (emptyOptions & #thinking .~ Just ThinkingMinimal)),+      testCase "a level this transport expresses exactly is not refused" $ do+        let m =+              emptyModel+                & #modelId .~ "claude-reasoning"+                & #api .~ AnthropicMessages+                & #reasoning .~ True+                & #maxOutputTokens .~ 64000+            opts = emptyOptions & #thinking .~ Just ThinkingMedium+        checkEvidenceRequirements+          (EvidenceRequired EvidenceModelObserved)+          AnthropicMessages+          (describeThinkingFor m opts)+          @?= []+    ]+  where+    expectDowngrade expected translation =+      case checkEvidenceRequirements+        (EvidenceRequired EvidenceRequestedOnly)+        AnthropicMessages+        translation of+        [ThinkingWouldDowngrade [reported]] -> reported @?= expected+        other -> assertFailure ("expected one downgrade refusal, got: " <> show other)++agentProviderGuardTest :: TestTree+agentProviderGuardTest =+  testCase "the claude renderer refuses a request that names codex" $ do+    let req = agentRunRequest AgentCodex "/work/project" "prompt"+    fmap fst (ClaudeAgent.claudeAgentCommand ClaudeAgent.defaultClaudeAgentConfig req)+      @?= Left (ProviderMismatch AgentClaude AgentCodex)++-- | The launch shape this initiative's first consumer embeds today in+-- @scripts/sync-keiro-dsl.sh@ in the @shinzui/keiro-syntax@ repository,+-- rendered from a provider-neutral request instead of Claude-specific+-- flags written into the script.+agentKeiroFixtureTest :: TestTree+agentKeiroFixtureTest =+  testCase "the sync-keiro-dsl launch shape renders without script-level claude flags" $ do+    let req =+          agentRunRequest AgentClaude "/work/keiro-syntax" "reconcile the Keiro DSL"+            & #extraDirs .~ ["/work/keiro"]+            & #safety+              .~ ( agentSafety AgentEditWorkspace+                     & #allowedTools+                       .~ [ "Read",+                            "Write",+                            "Edit",+                            "Glob",+                            "Grep",+                            "Bash",+                            "Skill",+                            "TodoWrite"+                          ]+                 )+    cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req+    cmd ^. #executable @?= "claude"+    cmd ^. #arguments+      @?= [ "-p",+            "--no-session-persistence",+            "--permission-mode",+            "acceptEdits",+            "--allowedTools",+            "Read,Write,Edit,Glob,Grep,Bash,Skill,TodoWrite",+            "--add-dir",+            "/work/keiro"+          ]+    cmd ^. #promptTransport @?= PromptOnStdin+    cmd ^. #promptText @?= "reconcile the Keiro DSL"  batchCommandRenderingTest :: TestTree batchCommandRenderingTest =

@@ -102,7 +102,7 @@  shapedBody :: Model -> Context -> Options -> IO Value shapedBody model ctx opts = do-  req <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts)+  (req, _) <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts)   pure (streamRequestBody (anthropicMessagesCompatFor model) ctx opts req)  objectSchema :: Value

@@ -1,18 +1,22 @@ module SseSpec (tests) where  import Baikai.Error (ErrorCategory (..), category, httpStatus, retryAfterSeconds)-import Baikai.Provider.Claude.Sse (sseFromResponse)+import Baikai.Evidence (Observed (..))+import Baikai.Models.Generated (anthropic_claude_haiku_4_5)+import Baikai.Provider.Claude.Api (Assembler, emptyAssembler, translate)+import Baikai.Provider.Claude.Sse (ResponseMetadata, sseFromResponse) import Claude.V1.Messages qualified as Messages import Control.Lens ((^.)) import Data.ByteString (ByteString) import Data.CaseInsensitive qualified as CI import Data.Generics.Labels () import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Time.Clock (UTCTime) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  tests :: TestTree tests =@@ -20,8 +24,9 @@     "Baikai.Provider.Claude.Sse"     [ testCase "non-2xx response preserves Retry-After and status" $ do         eventsRef <- newIORef []+        metaRef <- newIORef []         resp <- mkResponse 429 [("Retry-After", "7")] ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"]-        sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev]))+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))         events <- readIORef eventsRef         case events of           [Left e] -> do@@ -31,6 +36,7 @@           other -> assertFailure ("expected one classified error, got: " <> show other),       testCase "200 response decodes split SSE data frames in order" $ do         eventsRef <- newIORef []+        metaRef <- newIORef []         resp <-           mkResponse             200@@ -40,13 +46,104 @@               "\"usage\":{\"input_tokens\":3,\"output_tokens\":0}}}\r\n\r\n",               "data: {\"type\":\"message_stop\"}\n\n"             ]-        sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev]))+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))         events <- readIORef eventsRef         case events of           [Right Messages.Message_Start {Messages.message = msg}, Right Messages.Message_Stop] ->             msg ^. #id @?= "msg_1"-          other -> assertFailure ("expected message_start then message_stop, got: " <> show other)+          other -> assertFailure ("expected message_start then message_stop, got: " <> show other),+      observationTests     ]++-- | What the transport and the assembler between them can say about+-- what Anthropic reported, as opposed to what was configured.+--+-- The fixture's @model@ deliberately differs from the model the+-- assembler was built with. If they matched, a bug that read the+-- caller's configuration instead of the provider's event would pass+-- these assertions, which is exactly the substitution the 'Observed'+-- type exists to prevent.+observationTests :: TestTree+observationTests =+  testGroup+    "response observation"+    [ testCase "a 200 response yields one metadata value carrying request-id" $ do+        (metas, _) <- replay 200 [("request-id", "req_abc123"), ("x-api-key", "sk-leak")] successBody+        case metas of+          [md] -> do+            md ^. #httpStatus @?= 200+            -- Allow-list, not denylist: the credential-shaped header the+            -- fixture also carries must not be recorded.+            md ^. #headers @?= [("request-id", "req_abc123")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other),+      testCase "the observed model comes from message_start, not the configured model" $ do+        (_, ass) <- replay 200 [("request-id", "req_abc123")] successBody+        ass ^. #observedModel @?= Observed "claude-haiku-4-5-20990101-server-side"+        -- Asserted as a difference rather than against a literal+        -- catalog id, which is generated and moves.+        assertBool+          "the fixture's model must differ from the configured one"+          (ass ^. #observedModel /= Observed (anthropic_claude_haiku_4_5 ^. #modelId))+        ass ^. #responseId @?= Just "msg_observed"+        ass ^. #usageReported @?= True,+      testCase "a failed response still yields metadata, and observes no model" $ do+        (metas, ass) <-+          replay+            429+            [("request-id", "req_failed")]+            ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"]+        case metas of+          [md] -> do+            md ^. #httpStatus @?= 429+            md ^. #headers @?= [("request-id", "req_failed")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other)+        ass ^. #observedModel @?= Unobserved+        ass ^. #usageReported @?= False,+      testCase "a gateway header is captured when Anthropic's own is absent" $ do+        (metas, _) <- replay 200 [("cf-ray", "ray-9"), ("x-request-id", "gw-1")] successBody+        case metas of+          -- Recorded in the order the response listed them; the+          -- adapter's preference order lives in capturedHeaderNames.+          [md] -> md ^. #headers @?= [("cf-ray", "ray-9"), ("x-request-id", "gw-1")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other)+    ]++-- | A complete successful stream whose reported model is not any model+-- in the catalog, so it cannot be confused with a configured one.+successBody :: [ByteString]+successBody =+  [ "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_observed\",\"type\":\"message\",",+    "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-haiku-4-5-20990101-server-side\",",+    "\"stop_reason\":null,\"stop_sequence\":null,",+    "\"usage\":{\"input_tokens\":11,\"output_tokens\":0}}}\n\n",+    "data: {\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},",+    "\"usage\":{\"output_tokens\":5}}\n\n",+    "data: {\"type\":\"message_stop\"}\n\n"+  ]++-- | Drive a recorded response through the real transport and fold the+-- events it produces through the real translator.+replay ::+  Int -> [(ByteString, ByteString)] -> [ByteString] -> IO ([ResponseMetadata], Assembler)+replay status headers chunks = do+  metaRef <- newIORef []+  eventsRef <- newIORef []+  resp <- mkResponse status headers chunks+  sseFromResponse+    resp+    (\md -> modifyIORef' metaRef (<> [md]))+    (\ev -> modifyIORef' eventsRef (<> [ev]))+  metas <- readIORef metaRef+  events <- readIORef eventsRef+  let ass =+        foldl'+          (\acc ev -> snd (translate ev acc testTime))+          (emptyAssembler anthropic_claude_haiku_4_5 testTime)+          events+  pure (metas, ass)++testTime :: UTCTime+testTime = read "2026-07-03 12:00:00 UTC"  mkResponse :: Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader) mkResponse status headers chunks = do

@@ -15,6 +15,7 @@ import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector+import Numeric.Natural (Natural) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -23,6 +24,8 @@   testGroup     "ThinkingSpec"     [ testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests),+      translationTableTests,+      conditionalDowngradeTests,       adaptiveHigherEffortTests,       maxBudgetTest,       explicitMaxTokensTest,@@ -86,6 +89,110 @@     (levelName, level) <- thinkingLevels   ] +-- | Every canonical level against both Anthropic thinking styles, with+-- the exact effort text, exact budget, and exact adjustment list each+-- one produces.+--+-- The expected values are written out rather than computed from the+-- functions under test, so a change to either mapping fails a row here+-- instead of quietly agreeing with itself. A failing row is either a+-- transcription error or a real behaviour change, and the two must be+-- told apart before either side is edited.+translationTable ::+  [(AnthropicThinkingStyle, ThinkingLevel, Maybe Text.Text, Maybe Natural, [ThinkingAdjustment])]+translationTable =+  [ -- A token budget expresses every level exactly: nothing is adjusted.+    (AnthropicThinkingBudget, ThinkingMinimal, Nothing, Just 1024, []),+    (AnthropicThinkingBudget, ThinkingLow, Nothing, Just 2048, []),+    (AnthropicThinkingBudget, ThinkingMedium, Nothing, Just 8192, []),+    (AnthropicThinkingBudget, ThinkingHigh, Nothing, Just 16384, []),+    (AnthropicThinkingBudget, ThinkingXHigh, Nothing, Just 24576, []),+    (AnthropicThinkingBudget, ThinkingMax, Nothing, Just 32768, []),+    -- Anthropic's adaptive vocabulary has no "minimal", so the lowest+    -- level is clamped up to "low" and says so.+    ( AnthropicThinkingAdaptive,+      ThinkingMinimal,+      Just "low",+      Nothing,+      [EffortClamped ThinkingMinimal "low"]+    ),+    (AnthropicThinkingAdaptive, ThinkingLow, Just "low", Nothing, []),+    (AnthropicThinkingAdaptive, ThinkingMedium, Just "medium", Nothing, []),+    -- "high" sends no effort field at all, which on the wire is+    -- indistinguishable from expressing no preference.+    ( AnthropicThinkingAdaptive,+      ThinkingHigh,+      Nothing,+      Nothing,+      [EffortOmitted ThinkingHigh]+    ),+    (AnthropicThinkingAdaptive, ThinkingXHigh, Just "xhigh", Nothing, []),+    (AnthropicThinkingAdaptive, ThinkingMax, Just "max", Nothing, [])+  ]++translationTableTests :: TestTree+translationTableTests =+  testGroup+    "thinking translation table"+    [ testCase (show style <> " " <> Text.unpack (renderThinkingLevel level)) $ do+        t <- translationFor (modelWithStyle style) (emptyOptions & #thinking .~ Just level)+        t ^. #requested @?= Just level+        t ^. #mode @?= expectedMode+        t ^. #effortText @?= expectedEffort+        t ^. #budgetTokens @?= expectedBudget+        t ^. #wireField @?= Just "thinking"+        t ^. #adjustments @?= expectedAdjustments+    | (style, level, expectedEffort, expectedBudget, expectedAdjustments) <- translationTable,+      let expectedMode = case style of+            AnthropicThinkingBudget -> ThinkingModeBudget+            AnthropicThinkingAdaptive -> ThinkingModeAdaptive+    ]++-- | A reasoning model whose thinking style is pinned explicitly, so a+-- row of the table above depends on the style it names rather than on+-- which model generation happens to default to it.+modelWithStyle :: AnthropicThinkingStyle -> Model+modelWithStyle style =+  anthropic_claude_haiku_4_5+    & #compat .~ CompatAnthropicMessages (defaultAnthropicMessagesCompat {thinkingStyle = style})++-- | The two downgrades that depend on the model rather than the level:+-- a model that cannot reason at all, and an output ceiling too small to+-- hold the budget the level asks for. Neither was visible anywhere in+-- baikai's output before this plan.+conditionalDowngradeTests :: TestTree+conditionalDowngradeTests =+  testGroup+    "conditional thinking downgrades"+    [ testCase "a non-reasoning model drops thinking and records why" $ do+        let model = anthropic_claude_haiku_4_5 & #reasoning .~ False+        req <- requestFor model (emptyOptions & #thinking .~ Just ThinkingMedium)+        requestThinking req @?= Nothing+        t <- translationFor model (emptyOptions & #thinking .~ Just ThinkingMedium)+        t ^. #requested @?= Just ThinkingMedium+        t ^. #mode @?= ThinkingModeUnsupported+        t ^. #wireField @?= Nothing+        t ^. #budgetTokens @?= Nothing+        t ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingMedium],+      testCase "an output ceiling at or below the budget drops thinking and names both numbers" $ do+        -- 1000 is below ThinkingMinimal's 1024-token budget, so the+        -- resolved ceiling collapses onto the cap and the budget can no+        -- longer fit inside it.+        let model = anthropic_claude_haiku_4_5 & #maxOutputTokens .~ 1000+            opts = emptyOptions & #thinking .~ Just ThinkingMinimal+        req <- requestFor model opts+        requestThinking req @?= Nothing+        Messages.max_tokens req @?= 1000+        t <- translationFor model opts+        t ^. #requested @?= Just ThinkingMinimal+        t ^. #mode @?= ThinkingModeUnsupported+        t ^. #wireField @?= Nothing+        t ^. #budgetTokens @?= Nothing+        t ^. #effortText @?= Nothing+        t ^. #adjustments+          @?= [ThinkingDroppedBudgetExceeded ThinkingMinimal 1024 1000]+    ]+ adaptiveHigherEffortTests :: TestTree adaptiveHigherEffortTests =   testGroup@@ -188,9 +295,16 @@     (Messages.output_config req >>= Messages.effort) @?= Just "low"  requestFor :: Model -> Options -> IO Messages.CreateMessage-requestFor model opts = case mapRequest model emptyContext opts of+requestFor model opts = fst <$> mappedFor model emptyContext opts++translationFor :: Model -> Options -> IO ThinkingTranslation+translationFor model opts = snd <$> mappedFor model emptyContext opts++mappedFor ::+  Model -> Context -> Options -> IO (Messages.CreateMessage, ThinkingTranslation)+mappedFor model ctx opts = case mapRequest model ctx opts of   Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)-  Right req -> pure req+  Right mapped -> pure mapped  requestThinking :: Messages.CreateMessage -> Maybe Messages.Thinking requestThinking Messages.CreateMessage {Messages.thinking = t} = t@@ -400,9 +514,7 @@     _ -> error "last event was not terminal"  requestForContext :: Model -> Context -> Options -> IO Messages.CreateMessage-requestForContext model ctx opts = case mapRequest model ctx opts of-  Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)-  Right req -> pure req+requestForContext model ctx opts = fst <$> mappedFor model ctx opts  requestMessages :: Messages.CreateMessage -> Vector.Vector Messages.Message requestMessages Messages.CreateMessage {Messages.messages = msgs} = msgs