baikai-claude 0.2.0.0 → 0.3.0.0

raw patch · 16 files changed

+2172/−582 lines, 16 filesdep +cryptondep +directorydep +filepathdep ~baikaiPVP ok

version bump matches the API change (PVP)

Dependencies added: crypton, directory, filepath

Dependency ranges changed: baikai

API changes (from Hackage documentation)

Files

• baikai-claude.cabal +19/−5
• src/Baikai/Provider/Claude/Api.hs +204/−368
• src/Baikai/Provider/Claude/Cli.hs +86/−47
• src/Baikai/Provider/Claude/ErrorClass.hs +0/−129
• src/Baikai/Provider/Claude/Interactive.hs +12/−10
• src/Baikai/Provider/Claude/Internal/ErrorClass.hs +168/−0
• src/Baikai/Provider/Claude/Internal/Request.hs +324/−0
• src/Baikai/Provider/Claude/Shape.hs +129/−0
• src/Baikai/Provider/Claude/Sse.hs +172/−0
• src/Baikai/Provider/Claude/Transport.hs +164/−0
• test/ErrorClassSpec.hs +43/−5
• test/Main.hs +182/−18
• test/ShapeSpec.hs +126/−0
• test/SseSpec.hs +69/−0
• test/ThinkingSpec.hs +378/−0
• test/TransportSpec.hs +96/−0

@@ -1,6 +1,6 @@ cabal-version: 3.4 name:          baikai-claude-version:       0.2.0.0+version:       0.3.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@@ -34,12 +34,16 @@   exposed-modules:     Baikai.Provider.Claude.Api     Baikai.Provider.Claude.Cli-    Baikai.Provider.Claude.ErrorClass     Baikai.Provider.Claude.Interactive+    Baikai.Provider.Claude.Internal.ErrorClass+    Baikai.Provider.Claude.Internal.Request+    Baikai.Provider.Claude.Shape+    Baikai.Provider.Claude.Sse+    Baikai.Provider.Claude.Transport    build-depends:     , aeson-    , baikai             ^>=0.2.0+    , baikai             ^>=0.3.0     , base               >=4.20   && <5     , base64-bytestring     , bytestring@@ -47,6 +51,7 @@     , claude     , containers     , cradle+    , crypton     , generic-lens     , http-client     , http-client-tls@@ -64,20 +69,28 @@   type:           exitcode-stdio-1.0   hs-source-dirs: test   main-is:        Main.hs-  other-modules:  ErrorClassSpec+  other-modules:+    ErrorClassSpec+    ShapeSpec+    SseSpec+    ThinkingSpec+    TransportSpec    -- cradle (used by Baikai.Provider.Claude.Interactive) requires the threaded RTS.   ghc-options:    -threaded -with-rtsopts=-N   build-depends:     , aeson-    , baikai            ^>=0.2.0+    , baikai            ^>=0.3.0     , baikai-claude     , base              >=4.20   && <5     , bytestring     , case-insensitive     , claude     , containers+    , directory+    , filepath     , generic-lens+    , http-client     , http-types     , lens              ^>=5.3     , servant-client@@ -85,4 +98,5 @@     , tasty     , tasty-hunit     , text              ^>=2.1+    , time     , vector

@@ -9,43 +9,53 @@ -- this handler. -- -- The handler resolves 'Baikai.Options.apiKey' when present, falling--- back to the @ANTHROPIC_API_KEY@ env var via--- 'Baikai.Auth.resolveApiKey'.+-- back to the host-specific env var from+-- 'Baikai.Auth.defaultApiKeyEnvForBaseUrl'. Unknown hosts require an+-- explicit key source. -- -- EP-3 promotes streaming to the primary entry point. The handler -- exposes a 'streamly' 'Stream' of 'AssistantMessageEvent' values--- bridged from the upstream SDK's typed 'createMessageStreamTyped'--- callback. The synchronous 'complete' field is derived via--- 'streamingComplete', so callers that drain the stream get the--- same fully-assembled 'Response' they had before.+-- bridged from a local SSE transport that preserves HTTP status,+-- headers, and body for error classification. Requests start as the+-- SDK's typed 'Claude.V1.Messages.CreateMessage' value, then+-- 'Baikai.Provider.Claude.Shape.streamRequestBody' patches the raw+-- JSON body for tool-schema, @tool_choice@, and tool-cache compat+-- before 'Baikai.Provider.Claude.Sse.claudeSseStreamValueWithHeaders'+-- sends it with cached transport settings and caller headers. The+-- synchronous 'complete' field is derived via 'streamingComplete',+-- so callers that drain the stream get the same fully-assembled+-- 'Response' they had before. module Baikai.Provider.Claude.Api   ( register,     registerWithRegistry,+    claudeMessagesProvider,     claudeMessagesStream,-    mapRequest,+    Assembler (..),+    emptyAssembler,+    translate,   ) where  import Baikai.Api (Api (..))-import Baikai.Auth qualified as Auth-import Baikai.CacheRetention (CacheRetention (..))-import Baikai.Compat (AnthropicMessagesCompat (..)) import Baikai.Content qualified as Content import Baikai.Context (Context (..))-import Baikai.Cost (_Cost)+import Baikai.Cost (zeroCost) import Baikai.Cost.Pricing qualified as Pricing-import Baikai.Error (BaikaiError, invalidRequest)+import Baikai.Error (BaikaiError, invalidRequest, providerError) import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..))-import Baikai.Provider.Claude.ErrorClass (classifyErrorValue, classifyException)+import Baikai.Provider.Claude.Internal.ErrorClass (classifyErrorValue, classifyException)+import Baikai.Provider.Claude.Internal.Request (mapRequest)+import Baikai.Provider.Claude.Shape (streamRequestBody)+import Baikai.Provider.Claude.Sse (claudeSseStreamValueWithHeaders)+import Baikai.Provider.Claude.Transport qualified as Transport import Baikai.Provider.Registry   ( ApiProvider (..),     ProviderRegistry,-    globalProviderRegistry,+    registerApiProvider,     registerApiProviderWith,   )-import Baikai.ResponseFormat (ResponseFormat (..)) import Baikai.StopReason qualified as Stop import Baikai.Stream (streamingComplete) import Baikai.Stream.Event@@ -54,25 +64,20 @@     DeltaPayload (..),     IndexPayload (..),     StartPayload (..),+    ThinkingEndPayload (..),     ToolCallEndPayload (..),     doneTerminal,     errorTerminal,   )-import Baikai.ThinkingLevel (ThinkingLevel, thinkingTokenBudget)-import Baikai.Tool qualified as Tool import Baikai.Usage qualified as Usage-import Claude.V1 qualified as Claude import Claude.V1.Messages qualified as Messages-import Claude.V1.Tool qualified as ClaudeTool import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Exception (SomeException, try)+import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try) import Control.Lens ((%~), (&), (.~), (^.))-import Data.Aeson (Value, (.=))+import Data.Aeson (Value) import Data.Aeson qualified as Aeson-import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Lazy qualified as BSL-import Data.Char (isAlphaNum, isAscii) import Data.Generics.Labels () import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IntMap.Strict (IntMap)@@ -85,6 +90,8 @@ import Data.Vector (Vector) import Data.Vector qualified as Vector import GHC.Generics (Generic)+import Network.HTTP.Types.Header (RequestHeaders)+import Servant.Client qualified as Client import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream @@ -92,27 +99,35 @@ -- Calling 'register' twice keeps only the second handler — the -- registry's insert-overwrites semantic. register :: IO ()-register = registerWithRegistry globalProviderRegistry+register = registerApiProvider claudeMessagesProvider +-- | First-class Anthropic Messages provider value. Use with+-- 'registerApiProviderWith' or 'newProviderRegistryFrom' for explicit+-- registries.+claudeMessagesProvider :: ApiProvider+claudeMessagesProvider =+  ApiProvider+    { apiTag = AnthropicMessages,+      stream = claudeMessagesStream,+      complete = streamingComplete claudeMessagesStream+    }+ -- | Install the Anthropic Messages handler into an explicit registry. registerWithRegistry :: ProviderRegistry -> IO () registerWithRegistry reg =   registerApiProviderWith     reg-    ApiProvider-      { apiTag = AnthropicMessages,-        stream = claudeMessagesStream,-        complete = streamingComplete claudeMessagesStream-      }+    claudeMessagesProvider+{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg claudeMessagesProvider" #-}  -- | Streaming producer for the Anthropic Messages API. -- -- Forks one worker thread per call that drives--- 'Claude.createMessageStreamTyped'; the worker pushes typed--- 'Messages.MessageStreamEvent' values onto a bounded 'Chan'--- terminated by 'Nothing'. The returned 'Stream' is a translator:--- it pulls raw events from the channel and emits zero or more--- 'AssistantMessageEvent' values per upstream event, terminating+-- the local Claude SSE transport; the worker pushes classified+-- errors or typed 'Messages.MessageStreamEvent' values onto a bounded+-- 'Chan' terminated by 'Nothing'. The returned 'Stream' is a+-- translator: it pulls raw events from the channel and emits zero or+-- more 'AssistantMessageEvent' values per upstream event, terminating -- with exactly one 'EventDone' or 'EventError'. -- -- Producer-side exceptions (HTTP failure, decode failure inside the@@ -123,14 +138,14 @@   Model -> Context -> Options -> Stream IO AssistantMessageEvent claudeMessagesStream m ctx opts =   Stream.concatEffect $ do-    setup <- prepareCall m ctx opts+    setupResult <- trySync (prepareCall m ctx opts)+    let setup = either (Left . exceptionToError) id setupResult     case setup of-      Left err -> pure (Stream.fromEffect (immediateError err))+      Left err -> Stream.fromList <$> immediateError err       Right call -> do-        ch <- newChan :: IO (Chan (Maybe Messages.MessageStreamEvent))+        ch <- newChan :: IO (Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)))         tref <- newIORef False-        eref <- newIORef Nothing-        _ <- forkIO (worker call ch eref)+        _ <- forkIO (worker call ch)         startTime <- getCurrentTime         let initialState =               ProducerState@@ -138,37 +153,44 @@                   pending = [],                   assembler = emptyAssembler m startTime,                   finished = False,-                  terminalRef = tref,-                  errInfoRef = eref+                  terminalRef = tref                 }         pure (Stream.unfoldrM step initialState) --- | Per-call prepared values: the typed SDK request, plus the--- methods record to invoke the streaming endpoint.+-- | Per-call prepared values, including the shaped JSON request body+-- passed to the local streaming transport. data ClaudeCall = ClaudeCall-  { methods :: !Claude.Methods,-    request :: !Messages.CreateMessage+  { clientEnv :: !Client.ClientEnv,+    requestHeaders :: !RequestHeaders,+    timeoutMs :: !(Maybe Int),+    requestBody :: !Aeson.Value   }   deriving stock (Generic)  prepareCall ::-  Model -> Context -> Options -> IO (Either Text ClaudeCall)+  Model -> Context -> Options -> IO (Either BaikaiError ClaudeCall) prepareCall m ctx opts = do   case mapRequest m ctx opts of-    Left e -> pure (Left e)+    Left e -> pure (Left (invalidRequest e))     Right req -> do-      key <- resolveKey opts       let url = case m ^. #baseUrl of             "" -> "https://api.anthropic.com"             u -> u-      env <- Claude.getClientEnv url-      let mtds = Claude.makeMethods env key (Just "2023-06-01")-      pure (Right ClaudeCall {methods = mtds, request = req})--resolveKey :: Options -> IO Text-resolveKey opts = case opts ^. #apiKey of-  Just source -> Auth.resolveApiKey source-  Nothing -> Auth.resolveApiKey (Auth.ApiKeyEnv "ANTHROPIC_API_KEY")+          compat = anthropicMessagesCompatFor m+          version = Just "2023-06-01"+      key <- Transport.resolveKey url opts+      env <- Transport.getClientEnvCached url+      let body = streamRequestBody compat ctx opts req+          headers = Transport.requestHeaders key version compat ctx m opts+      pure+        ( Right+            ClaudeCall+              { clientEnv = env,+                requestHeaders = headers,+                timeoutMs = opts ^. #timeoutMs,+                requestBody = body+              }+        )  -- | Worker body: drive the SDK's typed callback, forwarding events -- onto the channel. Any exception is converted into a synthetic@@ -177,38 +199,30 @@ -- handled failure) we close the channel with 'Nothing'. worker ::   ClaudeCall ->-  Chan (Maybe Messages.MessageStreamEvent) ->-  IORef (Maybe BaikaiError) ->+  Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)) ->   IO ()-worker call ch errInfoRef = do-  let Claude.Methods {Claude.createMessageStreamTyped = stream'} = call ^. #methods+worker call ch = do   r <--    try @SomeException $-      stream' (call ^. #request) $ \case-        Left errText -> writeChan ch (Just (errorEvent errText))-        Right ev -> writeChan ch (Just ev)+    trySync $+      Transport.runWithTimeout (call ^. #timeoutMs) $+        claudeSseStreamValueWithHeaders+          (call ^. #clientEnv)+          (call ^. #requestHeaders)+          (call ^. #requestBody)+          (writeChan ch . Just)   case r of-    Right () -> pure ()-    -- An HTTP-level exception carries an HTTP status; classify it and-    -- stash the structured error. The worker writes no terminal event,-    -- so the consumer reaches its end-of-stream recovery path, which-    -- reads this ref. (See 'step' / 'unexpectedEoS'.)-    Left e -> writeIORef errInfoRef (Just (classifyException e))+    Right Nothing -> pure ()+    Right (Just be) -> writeChan ch (Just (Left be))+    Left e -> writeChan ch (Just (Left (exceptionToError e)))   writeChan ch Nothing-  where-    errorEvent :: Text -> Messages.MessageStreamEvent-    errorEvent t = Messages.Error {Messages.error = Aeson.String t}  -- | The streaming 'Stream' state. data ProducerState = ProducerState-  { chan :: !(Chan (Maybe Messages.MessageStreamEvent)),+  { chan :: !(Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent))),     pending :: ![AssistantMessageEvent],     assembler :: !Assembler,     finished :: !Bool,-    terminalRef :: !(IORef Bool),-    -- | Set by the worker when an HTTP-level exception is caught, so the-    -- end-of-stream recovery path can surface a categorised error.-    errInfoRef :: !(IORef (Maybe BaikaiError))+    terminalRef :: !(IORef Bool)   }   deriving stock (Generic) @@ -234,8 +248,7 @@             then pure Nothing             else do               now <- getCurrentTime-              mErr <- readIORef (s ^. #errInfoRef)-              let (ev, ass') = unexpectedEoS now mErr (s ^. #assembler)+              let (ev, ass') = unexpectedEoS now (s ^. #assembler)               writeTerminal s ev               pure                 ( Just@@ -271,17 +284,13 @@   EventError {} -> True   _ -> False --- | The recovery path: channel closed before any terminal event. When--- the worker stored a classified HTTP error ('Just be'), surface it as a--- structured 'EventError'; otherwise report the unexpected end of stream.+-- | The recovery path: channel closed before any terminal event. unexpectedEoS ::-  UTCTime -> Maybe BaikaiError -> Assembler -> (AssistantMessageEvent, Assembler)-unexpectedEoS now mErr ass =-  let errText = case mErr of-        Just be -> be ^. #message-        Nothing -> "claude stream ended without message_stop"+  UTCTime -> Assembler -> (AssistantMessageEvent, Assembler)+unexpectedEoS now ass =+  let errText = "claude stream ended without message_stop"       msg = finalMessageOnError ass now errText-   in (EventError (errorTerminal Stop.ErrorReason msg mErr), ass)+   in (EventError (errorTerminal (ass ^. #responseId) Stop.ErrorReason msg (providerError errText)), ass)  -- | Translation state across one streaming call. data Assembler = Assembler@@ -292,6 +301,7 @@     textBuf :: !(IntMap Text),     thinkBuf :: !(IntMap Text),     thinkSig :: !(IntMap Text),+    redactedBuf :: !(IntMap Text),     toolArgsBuf :: !(IntMap Text),     toolMeta :: !(IntMap (Text, Text)),     usage :: !Usage.Usage,@@ -309,24 +319,36 @@       textBuf = IntMap.empty,       thinkBuf = IntMap.empty,       thinkSig = IntMap.empty,+      redactedBuf = IntMap.empty,       toolArgsBuf = IntMap.empty,       toolMeta = IntMap.empty,-      usage = Usage._Usage,+      usage = Usage.zeroUsage,       stopReason = Stop.Stop     }  translate ::-  Messages.MessageStreamEvent ->+  Either BaikaiError Messages.MessageStreamEvent ->   Assembler ->   UTCTime ->   ([AssistantMessageEvent], Assembler) 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)+  Right ev -> translateEvent ev ass now++translateEvent ::+  Messages.MessageStreamEvent ->+  Assembler ->+  UTCTime ->+  ([AssistantMessageEvent], Assembler)+translateEvent raw ass now = case raw of   Messages.Ping -> ([], ass)   Messages.Message_Start {Messages.message = mr} ->     let usage0 = anthroUsageToBaikai (mr ^. #usage)         ass' = ass & #responseId .~ Just (mr ^. #id) & #usage .~ usage0         skeleton = skeletonMessage ass' now-     in ([EventStart StartPayload {partial = skeleton}], ass')+     in ([EventStart StartPayload {partial = skeleton, responseId = Just (mr ^. #id)}], ass')   Messages.Content_Block_Start {Messages.index = idx, Messages.content_block = block} ->     handleBlockStart (fromIntegral idx) block ass   Messages.Content_Block_Delta {Messages.index = idx, Messages.delta = d} ->@@ -344,13 +366,23 @@               .~ ((u ^. #inputTokens) + outputTokensFinal + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens))      in ([], ass & #stopReason .~ stopR & #usage .~ u')   Messages.Message_Stop ->-    let msg = finalMessage ass now-     in ([EventDone (doneTerminal (ass ^. #stopReason) msg)], ass)+    let reason = ass ^. #stopReason+        refusal = providerError "Anthropic refused to generate a response (stop_reason=refusal)"+        msg =+          if reason == Stop.ErrorReason+            then finalMessageOnError ass now (refusal ^. #message)+            else finalMessage ass now+        terminalEvent =+          if reason == Stop.ErrorReason+            then EventError (errorTerminal (ass ^. #responseId) reason msg refusal)+            else EventDone (doneTerminal (ass ^. #responseId) reason msg)+     in ([terminalEvent], ass)   Messages.Error {Messages.error = errVal} ->     let errText = renderAnthropicError errVal         mErr = classifyErrorValue errVal         msg = finalMessageOnError ass now errText-     in ([EventError (errorTerminal Stop.ErrorReason msg mErr)], ass)+        errInfo = fromMaybe (providerError errText) mErr+     in ([EventError (errorTerminal (ass ^. #responseId) Stop.ErrorReason msg errInfo)], ass)  handleBlockStart ::   Int ->@@ -366,9 +398,9 @@     ( [ThinkingStart IndexPayload {contentIndex = i}],       ass & #thinkBuf %~ IntMap.insert i Text.empty     )-  Messages.ContentBlock_Redacted_Thinking {} ->+  Messages.ContentBlock_Redacted_Thinking {Messages.data_ = payload} ->     ( [ThinkingStart IndexPayload {contentIndex = i}],-      ass & #thinkBuf %~ IntMap.insert i Text.empty+      ass & #redactedBuf %~ IntMap.insert i payload     )   Messages.ContentBlock_Tool_Use {Messages.id = tid, Messages.name = tn} ->     ( [ToolCallStart IndexPayload {contentIndex = i}],@@ -387,24 +419,36 @@   ([AssistantMessageEvent], Assembler) handleBlockDelta i d ass = case d of   Messages.Delta_Text_Delta {Messages.text = t} ->-    ( [TextDelta DeltaPayload {contentIndex = i, delta = t}],-      ass & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i t-    )+    if IntMap.member i (ass ^. #textBuf)+      then+        ( [TextDelta DeltaPayload {contentIndex = i, delta = t}],+          ass & #textBuf %~ IntMap.adjust (<> t) i+        )+      else ([], ass)   Messages.Delta_Thinking_Delta {Messages.thinking = t} ->-    ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}],-      ass & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i t-    )+    if IntMap.member i (ass ^. #thinkBuf)+      then+        ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}],+          ass & #thinkBuf %~ IntMap.adjust (<> t) i+        )+      else ([], ass)   Messages.Delta_Signature_Delta {Messages.signature = sig} ->     -- Signatures are tail-end metadata on thinking blocks; they     -- attach to the ThinkingEnd event's content build, not a public     -- delta event.-    ( [],-      ass & #thinkSig %~ IntMap.insertWith (\new old -> old <> new) i sig-    )+    if IntMap.member i (ass ^. #thinkBuf)+      then+        ( [],+          ass & #thinkSig %~ IntMap.insertWith (\new old -> old <> new) i sig+        )+      else ([], ass)   Messages.Delta_Input_Json_Delta {Messages.partial_json = j} ->-    ( [ToolCallDelta DeltaPayload {contentIndex = i, delta = j}],-      ass & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i j-    )+    if IntMap.member i (ass ^. #toolArgsBuf)+      then+        ( [ToolCallDelta DeltaPayload {contentIndex = i, delta = j}],+          ass & #toolArgsBuf %~ IntMap.adjust (<> j) i+        )+      else ([], ass)  handleBlockStop ::   Int -> Assembler -> ([AssistantMessageEvent], Assembler)@@ -416,23 +460,39 @@               & #closed %~ IntMap.insert i block               & #textBuf %~ IntMap.delete i           )+  | Just payload <- IntMap.lookup i (ass ^. #redactedBuf) =+      let thinkingContent =+            Content.ThinkingContent+              { Content.thinking = payload,+                Content.signature = Nothing,+                Content.redacted = True+              }+          block = Content.AssistantThinking thinkingContent+       in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}],+            ass+              & #closed %~ IntMap.insert i block+              & #redactedBuf %~ IntMap.delete i+          )   | Just body <- IntMap.lookup i (ass ^. #thinkBuf) =       let sig = IntMap.lookup i (ass ^. #thinkSig)-          block =-            Content.AssistantThinking-              Content.ThinkingContent-                { Content.thinking = body,-                  Content.signature = if maybe True Text.null sig then Nothing else sig,-                  Content.redacted = False-                }-       in ( [ThinkingEnd BlockEndPayload {contentIndex = i, content = body}],+          thinkingContent =+            Content.ThinkingContent+              { Content.thinking = body,+                Content.signature = if maybe True Text.null sig then Nothing else sig,+                Content.redacted = False+              }+          block = Content.AssistantThinking thinkingContent+       in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}],             ass               & #closed %~ IntMap.insert i block               & #thinkBuf %~ IntMap.delete i               & #thinkSig %~ IntMap.delete i           )   | Just argsText <- IntMap.lookup i (ass ^. #toolArgsBuf) =-      let (tid, tn) = fromMaybe ("", "") (IntMap.lookup i (ass ^. #toolMeta))+      let (tid, tn) =+            -- A tool args buffer is opened together with metadata in+            -- handleBlockStart; the fallback is defensive only.+            fromMaybe ("", "") (IntMap.lookup i (ass ^. #toolMeta))           decoded :: Value           decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 argsText) of             Right v -> v@@ -467,7 +527,7 @@         Msg.usage = ass ^. #usage,         Msg.stopReason = Stop.Stop,         Msg.errorMessage = Nothing,-        Msg.timestamp = ass ^. #start+        Msg.timestamp = Just (ass ^. #start)       }  finalMessage :: Assembler -> UTCTime -> Msg.Message@@ -483,7 +543,7 @@             Msg.usage = usage',             Msg.stopReason = ass ^. #stopReason,             Msg.errorMessage = Nothing,-            Msg.timestamp = now+            Msg.timestamp = Just now           }  finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message@@ -499,7 +559,7 @@             Msg.usage = usage',             Msg.stopReason = Stop.ErrorReason,             Msg.errorMessage = Just reason,-            Msg.timestamp = now+            Msg.timestamp = Just now           }  blocksInOrder :: Assembler -> Vector Content.AssistantContent@@ -508,20 +568,37 @@ -- | The immediate "request invalid" stream — emitted when -- 'mapRequest' fails or 'prepareCall' is otherwise unable to build -- a valid SDK request.-immediateError :: Text -> IO AssistantMessageEvent-immediateError errText = do+immediateError :: BaikaiError -> IO [AssistantMessageEvent]+immediateError err = do   now <- getCurrentTime+  let errText = err ^. #message   let msg =         Msg.AssistantMessage           Msg.AssistantPayload             { Msg.content = Vector.empty,-              Msg.usage = Usage._Usage,+              Msg.usage = Usage.zeroUsage,               Msg.stopReason = Stop.ErrorReason,               Msg.errorMessage = Just errText,-              Msg.timestamp = now+              Msg.timestamp = Just now             }-  pure (EventError (errorTerminal Stop.ErrorReason msg (Just (invalidRequest errText))))+  pure+    [ EventStart StartPayload {partial = msg, responseId = Nothing},+      EventError (errorTerminal Nothing Stop.ErrorReason msg err)+    ] +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 (classifyException e) (fromException e)+ renderAnthropicError :: Value -> Text renderAnthropicError v = case v of   Aeson.String t -> t@@ -544,249 +621,8 @@           Usage.cacheWriteTokens = cw,           Usage.reasoningTokens = Nothing,           Usage.totalTokens = i + o + cr + cw,-          Usage.cost = _Cost-        }---- ============================================================--- Request mapping (preserved from EP-2 with minor refactoring to--- accept Context/Options directly).--- ============================================================--mapRequest :: Model -> Context -> Options -> Either Text Messages.CreateMessage-mapRequest m ctx opts = do-  msgs <- traverse mapMessage (Vector.toList (ctx ^. #messages))-  let compat = anthropicMessagesCompatFor m-      baseTokens = fromMaybe (m ^. #maxOutputTokens) (opts ^. #maxTokens)-      thinkingField = computeThinking m (opts ^. #thinking)-      -- When extended thinking is enabled, Anthropic requires that-      -- max_tokens be large enough to cover both the visible-      -- response and the thinking budget. Bump the cap by the-      -- requested budget so callers do not have to do the math.-      maxTokensField_ = case thinkingField of-        Just (Messages.ThinkingEnabled budget) -> baseTokens + budget-        _ -> baseTokens-      cacheControlField = computeCacheControl compat (opts ^. #cacheRetention)-      -- `ToolChoiceNone` is not a first-class Anthropic value; the-      -- standard way to disable tool use on a per-call basis is to-      -- omit the @tools@ field entirely. Suppress both fields when-      -- the caller asked for `None`.-      suppressTools = case opts ^. #toolChoice of-        Just Tool.ToolChoiceNone -> True-        _ -> False-      toolsVec = if suppressTools then Vector.empty else ctx ^. #tools-      toolsField =-        if Vector.null toolsVec-          then Nothing-          else Just (Vector.map (mkAnthropicTool compat) toolsVec)-      toolChoiceField = case opts ^. #toolChoice of-        Just Tool.ToolChoiceNone -> Nothing-        Just tc -> Just (mkAnthropicToolChoice tc)-        Nothing -> Nothing-      outputConfigField = 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.tools = toolsField,-        Messages.tool_choice = toolChoiceField,-        Messages.cache_control = cacheControlField,-        Messages.thinking = thinkingField,-        Messages.output_config = outputConfigField-      }---- | Map a baikai 'ResponseFormat' onto the upstream Anthropic--- 'Messages.OutputConfig'. 'JsonSchema' forwards the schema--- verbatim via 'Messages.jsonSchemaConfig'. Anthropic's structured--- outputs are always schema-enforcing, so the baikai 'strict' flag--- has no wire analog and is dropped. 'JsonObject' (plain-JSON mode)--- has no native Anthropic equivalent — 'output_config' requires a--- schema — so it downgrades to a permissive @{"type":"object"}@--- schema, which still forces the model to emit a JSON object.-mkAnthropicOutputConfig :: ResponseFormat -> Messages.OutputConfig-mkAnthropicOutputConfig = \case-  JsonSchema {schema = s} -> Messages.jsonSchemaConfig s-  JsonObject ->-    Messages.jsonSchemaConfig-      (Aeson.object ["type" .= ("object" :: Text)])---- | Translate the call-time 'Baikai.CacheRetention' preference into--- the Anthropic SDK's @cache_control@ shape.------ 'CacheRetentionNone' (and 'Nothing') turn the field off entirely.--- 'CacheRetentionShort' uses the ephemeral marker with no TTL (the--- provider default). 'CacheRetentionLong' asks for the @"1h"@ TTL--- when the host advertises 'supportsLongCacheRetention'; otherwise it--- transparently downgrades to short retention.-computeCacheControl ::-  AnthropicMessagesCompat ->-  Maybe CacheRetention ->-  Maybe Messages.CacheControl-computeCacheControl _ Nothing = Nothing-computeCacheControl _ (Just CacheRetentionNone) = Nothing-computeCacheControl _ (Just CacheRetentionShort) =-  Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing}-computeCacheControl compat (Just CacheRetentionLong)-  | supportsLongCacheRetention compat =-      Just-        Messages.CacheControl-          { Messages.type_ = "ephemeral",-            Messages.ttl = Just (Messages.CacheTTLDuration "1h")-          }-  | otherwise =-      Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing}---- | Translate the call-time 'Baikai.ThinkingLevel' preference into--- the Anthropic SDK's 'Messages.Thinking' shape.------ We only enable the thinking field when the chosen model advertises--- 'reasoning' support — sending a thinking config to a non-reasoning--- model is a 400 error from Anthropic, not a silent no-op. Callers--- that asked for thinking on a non-reasoning model get the request--- shaped without it (the request still succeeds and returns a normal--- response).-computeThinking :: Model -> Maybe ThinkingLevel -> Maybe Messages.Thinking-computeThinking _ Nothing = Nothing-computeThinking m (Just lvl)-  | m ^. #reasoning =-      Just Messages.ThinkingEnabled {Messages.budget_tokens = thinkingTokenBudget lvl}-  | otherwise = Nothing---- | Map a baikai 'Tool.Tool' into the upstream Anthropic--- 'ClaudeTool.ToolDefinition'. The JSON Schema is passed through--- verbatim; 'ClaudeTool.functionTool' extracts @properties@ and--- @required@ off the top-level schema if present.------ The compat record is threaded through so future revisions can--- apply per-tool @cache_control@ markers (when--- 'supportsCacheControlOnTools' is True) or per-tool eager input--- streaming flags. EP-5 ships the parameter at its default, leaving--- the upstream tool definition without cache markers.-mkAnthropicTool :: AnthropicMessagesCompat -> Tool.Tool -> ClaudeTool.ToolDefinition-mkAnthropicTool _compat t =-  ClaudeTool.inlineTool-    ( ClaudeTool.functionTool-        (Tool.name t)-        (Just (Tool.description t))-        (Tool.parameters t)-    )---- | Map a baikai 'Tool.ToolChoice' into the upstream Anthropic--- 'ClaudeTool.ToolChoice'. 'Tool.ToolChoiceNone' is handled at the--- call site by suppressing the @tools@ field — it never reaches--- this function. 'Tool.ToolChoiceRequired' maps to Anthropic's--- @any@ which is the closest equivalent ("must call some tool").-mkAnthropicToolChoice :: Tool.ToolChoice -> ClaudeTool.ToolChoice-mkAnthropicToolChoice = \case-  Tool.ToolChoiceAuto -> ClaudeTool.ToolChoice_Auto-  Tool.ToolChoiceRequired -> ClaudeTool.ToolChoice_Any-  Tool.ToolChoiceSpecific n -> ClaudeTool.ToolChoice_Tool {ClaudeTool.name = n}-  -- Unreachable: ToolChoiceNone is suppressed in 'mapRequest'.-  Tool.ToolChoiceNone -> ClaudeTool.ToolChoice_Auto---- | Anthropic enforces @[a-zA-Z0-9_-]+@ on tool-call ids and caps--- their length at 64 characters. Callers may have used any--- naming convention, so the provider boundary normalizes here--- whenever an id is round-tripped back to Anthropic — both on--- assistant turn replay ('Content_Tool_Use') and on tool-result--- messages ('Content_Tool_Result').-normalizeToolCallId :: Text -> Text-normalizeToolCallId =-  Text.take 64 . Text.map sanitise-  where-    sanitise c-      | isAscii c && isAlphaNum c = c-      | c == '_' || c == '-' = c-      | otherwise = '_'--mapMessage :: Msg.Message -> Either Text Messages.Message-mapMessage = \case-  Msg.UserMessage Msg.UserPayload {Msg.content = uc} ->-    Right-      Messages.Message-        { Messages.role = Messages.User,-          Messages.content = Vector.mapMaybe userContentToBlock uc,-          Messages.cache_control = Nothing-        }-  Msg.AssistantMessage Msg.AssistantPayload {Msg.content = ac} ->-    Right-      Messages.Message-        { Messages.role = Messages.Assistant,-          Messages.content = Vector.mapMaybe assistantContentToBlock ac,-          Messages.cache_control = Nothing-        }-  Msg.ToolResultMessage-    Msg.ToolResultPayload-      { Msg.toolCallId = tid,-        Msg.content = trc,-        Msg.isError = err-      } ->-      case concatToolResultText trc of-        Left unsupported -> Left unsupported-        Right body ->-          Right-            Messages.Message-              { Messages.role = Messages.User,-                Messages.content =-                  Vector.singleton-                    Messages.Content_Tool_Result-                      { Messages.tool_use_id = normalizeToolCallId tid,-                        Messages.content = nonEmpty body,-                        Messages.is_error = Just err-                      },-                Messages.cache_control = Nothing-              }--userContentToBlock :: Content.UserContent -> Maybe Messages.Content-userContentToBlock = \case-  Content.UserText (Content.TextContent t) ->-    Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing}-  Content.UserImage img ->-    Just-      Messages.Content_Image-        { Messages.source =-            Messages.ImageSource-              { Messages.type_ = "base64",-                Messages.media_type = Content.mimeType img,-                Messages.data_ = Text.decodeUtf8 (Base64.encode (Content.imageData img))-              },-          Messages.cache_control = Nothing-        }--assistantContentToBlock :: Content.AssistantContent -> Maybe Messages.Content-assistantContentToBlock = \case-  Content.AssistantText (Content.TextContent t) ->-    Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing}-  Content.AssistantThinking th ->-    Just-      Messages.Content_Thinking-        { Messages.thinking = Content.thinking th,-          Messages.signature = fromMaybe "" (Content.signature th)-        }-  Content.AssistantToolCall tc ->-    Just-      Messages.Content_Tool_Use-        { Messages.id = normalizeToolCallId (Content.id_ tc),-          Messages.name = Content.name tc,-          Messages.input = Content.arguments tc,-          Messages.caller = Nothing+          Usage.cost = zeroCost         }--concatToolResultText :: Vector Content.ToolResultContent -> Either Text Text-concatToolResultText =-  fmap (Text.concat . Vector.toList) . traverse oneBlock-  where-    oneBlock = \case-      Content.ToolResultText (Content.TextContent t) -> Right t-      Content.ToolResultImage _ ->-        Left "Anthropic Messages cannot encode ToolResultImage blocks in tool-result messages"--nonEmpty :: Text -> Maybe Text-nonEmpty t-  | Text.null t = Nothing-  | otherwise = Just t  mapStopReason :: Maybe Messages.StopReason -> Stop.StopReason mapStopReason = \case

@@ -10,11 +10,17 @@ -- 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 — the masterplan's Decision Log records the+-- in tool calling. Provider failures are returned in-band as+-- error-shaped responses; the masterplan's Decision Log records the -- reasoning. module Baikai.Provider.Claude.Cli-  ( ClaudeCliConfig (..),+  ( ClaudeCliConfig,+    executable,+    extraArgs,+    workingDir,+    claudeCliCommand,     defaultClaudeCliConfig,+    claudeCliProvider,     register,     registerWith,     registerWithRegistry,@@ -24,8 +30,8 @@  import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..))-import Baikai.Context (Context (..))-import Baikai.Error (decodeError, processError, providerError)+import Baikai.Context (Context)+import Baikai.Error (BaikaiError, decodeError, processError, providerError) import Baikai.Message (AssistantPayload (..)) import Baikai.Model (Model) import Baikai.Options (Options)@@ -33,14 +39,14 @@ import Baikai.Provider.Registry   ( ApiProvider (..),     ProviderRegistry,-    globalProviderRegistry,+    registerApiProvider,     registerApiProviderWith,   ) import Baikai.Response qualified as Resp import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream)-import Baikai.Usage (_Usage)-import Control.Exception (throwIO)+import Baikai.Usage (zeroUsage)+import Control.Exception (SomeAsyncException (..), SomeException, displayException, fromException, throwIO, try) import Control.Lens ((^.)) import Cradle   ( ExitCode (..),@@ -59,6 +65,7 @@ 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)@@ -69,7 +76,7 @@ -- | Configuration for the @claude -p@ subprocess. data ClaudeCliConfig = ClaudeCliConfig   { executable :: !FilePath,-    extraArgs :: !(Vector Text),+    extraArgs :: ![Text],     workingDir :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic)@@ -84,8 +91,17 @@  -- | Install the CLI handler with 'defaultClaudeCliConfig'. register :: IO ()-register = registerWith defaultClaudeCliConfig+register = registerApiProvider (claudeCliProvider defaultClaudeCliConfig) +-- | First-class Claude CLI provider value for a caller-supplied config.+claudeCliProvider :: ClaudeCliConfig -> ApiProvider+claudeCliProvider cfg =+  ApiProvider+    { apiTag = AnthropicMessagesCli,+      stream = liftCompleteToStream (runClaudeCli cfg),+      complete = runClaudeCli cfg+    }+ -- | Install the CLI handler with a caller-supplied config. -- -- The CLI binary runs in batch mode; there is no intra-response@@ -101,12 +117,14 @@ -- the deviation from the plan's "complete = streamingComplete . -- stream" default. registerWith :: ClaudeCliConfig -> IO ()-registerWith = registerWithRegistryAndConfig globalProviderRegistry+registerWith cfg = registerApiProvider (claudeCliProvider cfg)+{-# DEPRECATED registerWith "use registerApiProvider (claudeCliProvider cfg)" #-}  -- | Install the CLI handler with 'defaultClaudeCliConfig' into an explicit -- registry. registerWithRegistry :: ProviderRegistry -> IO () registerWithRegistry reg = registerWithRegistryAndConfig reg defaultClaudeCliConfig+{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg (claudeCliProvider defaultClaudeCliConfig)" #-}  -- | Install the CLI handler with a caller-supplied config into an explicit -- registry.@@ -114,12 +132,23 @@ registerWithRegistryAndConfig reg cfg =   registerApiProviderWith     reg-    ApiProvider-      { apiTag = AnthropicMessagesCli,-        stream = liftCompleteToStream (runClaudeCli cfg),-        complete = runClaudeCli cfg-      }+    (claudeCliProvider cfg)+{-# DEPRECATED registerWithRegistryAndConfig "use registerApiProviderWith reg (claudeCliProvider cfg)" #-} +-- | Render the executable and arguments for a @claude -p@ batch call.+-- The prompt is preceded by @--@ so dash-leading prompts and variadic+-- flags in 'extraArgs' cannot be parsed as options.+claudeCliCommand :: ClaudeCliConfig -> Model -> Context -> (FilePath, [String])+claudeCliCommand cfg m ctx =+  ( cfg ^. #executable,+    ["-p"]+      <> modelArgs m+      <> ["--output-format", "json", "--no-session-persistence"]+      <> systemPromptArgs ctx+      <> fmap Text.unpack (cfg ^. #extraArgs)+      <> ["--", Text.unpack (Internal.renderPrompt ctx)]+  )+ -- | The shape of @claude -p --output-format json@ stdout. data ClaudeCliResult = ClaudeCliResult   { result :: !Text,@@ -139,18 +168,18 @@   "" -> []   mid -> ["--model", Text.unpack mid] -decodeResult :: ByteString -> IO ClaudeCliResult+decodeResult :: ByteString -> Either BaikaiError ClaudeCliResult decodeResult bs = case eitherDecodeStrict bs of-  Left err -> throwIO (decodeError (Text.pack err))+  Left err -> Left (decodeError (Text.pack err))   Right (Aeson.Array events) -> case findResultEvent events of-    Nothing -> throwIO (decodeError "claude -p: no result event in stdout array")+    Nothing -> Left (decodeError "claude -p: no result event in stdout array")     Just ev -> case parseEither parseJSON ev of-      Left err -> throwIO (decodeError (Text.pack err))-      Right r -> pure r+      Left err -> Left (decodeError (Text.pack err))+      Right r -> Right r   Right v@(Aeson.Object _) -> case parseEither parseJSON v of-    Left err -> throwIO (decodeError (Text.pack err))-    Right r -> pure r-  Right _ -> throwIO (decodeError "claude -p: expected JSON object or array")+    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@@ -162,29 +191,26 @@  runClaudeCli :: ClaudeCliConfig -> Model -> Context -> Options -> IO Resp.Response runClaudeCli cfg m ctx _opts = do-  let prompt = Internal.renderPrompt ctx-      args =-        ["-p"]-          <> modelArgs m-          <> ["--output-format", "json", "--no-session-persistence"]-          <> systemPromptArgs ctx-          <> fmap Text.unpack (Vector.toList (cfg ^. #extraArgs))-          <> [Text.unpack prompt]+  let (exe, args) = claudeCliCommand cfg m ctx   start <- getCurrentTime-  (exitCode, StdoutRaw out, StderrRaw err) <--    run $-      cmd (cfg ^. #executable)-        & addArgs args-        & setNoStdin-        & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir+  executed <-+    trySync $+      run $+        cmd exe+          & addArgs args+          & setNoStdin+          & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir   end <- getCurrentTime-  case exitCode of-    ExitFailure n -> throwIO (processError n (Internal.decodeUtf8Lenient err))-    ExitSuccess -> do-      r <- decodeResult out-      if is_error r-        then throwIO (providerError (result r))-        else pure (mkResponse m start end (result r))+  case executed of+    Left ex -> pure (Resp.errorResponse m end (millisBetween start end) (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)+        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))  mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response mkResponse m start end body =@@ -192,10 +218,10 @@     { Resp.message =         AssistantPayload           { content = Vector.singleton (AssistantText (TextContent body)),-            usage = _Usage,+            usage = zeroUsage,             stopReason = Stop,             errorMessage = Nothing,-            timestamp = end+            timestamp = Just end           },       Resp.model = m,       Resp.api = AnthropicMessagesCli,@@ -205,5 +231,18 @@       Resp.errorInfo = Nothing     } -millisBetween :: UTCTime -> UTCTime -> Integer+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)

@@ -1,129 +0,0 @@--- | Map failures from the Anthropic SDK onto baikai's typed--- 'BaikaiError'. Two entry points cover the two ways a failure reaches--- the provider: 'classifyException' for an exception thrown by the--- @servant-client@ HTTP layer (carrying an HTTP status), and--- 'classifyErrorValue' for an Anthropic @error@ event that arrives--- mid-stream as a JSON 'Value'.-module Baikai.Provider.Claude.ErrorClass-  ( classifyException,-    classifyErrorValue,-    -- | Exposed for testing the HTTP-status mapping without a live call.-    responseToError,-  )-where--import Baikai.Error-  ( BaikaiError (..),-    ErrorCategory (..),-    bodyIndicatesOverflow,-    classifyHttpStatusWithBody,-    decodeError,-    providerError,-  )-import Control.Exception (SomeException, displayException, fromException)-import Data.Aeson (Value (..))-import Data.Aeson.KeyMap qualified as KeyMap-import Data.ByteString (ByteString)-import Data.ByteString.Lazy qualified as LBS-import Data.CaseInsensitive qualified as CI-import Data.Foldable (toList)-import Data.Sequence (Seq)-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 Network.HTTP.Types.Status (statusCode)-import Servant.Client (ClientError, ResponseF (..))-import Servant.Client qualified as Servant-import Text.Read (readMaybe)---- | Convert any exception caught from the Anthropic SDK into a--- categorised 'BaikaiError'. Recognises @servant-client@ 'ClientError';--- anything else degrades to a generic provider error carrying the--- displayed exception text.-classifyException :: SomeException -> BaikaiError-classifyException ex = case fromException ex of-  Just clientErr -> fromClientError clientErr-  Nothing -> providerError (Text.pack (displayException ex))--fromClientError :: ClientError -> BaikaiError-fromClientError clientErr = case clientErr of-  Servant.FailureResponse _req resp -> responseToError resp-  Servant.DecodeFailure detail _ -> decodeError detail-  Servant.UnsupportedContentType _ _ -> decodeError "unsupported content type in Anthropic response"-  Servant.InvalidContentTypeHeader _ -> decodeError "invalid content-type header in Anthropic response"-  Servant.ConnectionError exc ->-    (providerError ("connection error: " <> Text.pack (displayException exc)))-      { category = TransientError-      }---- | Build a 'BaikaiError' from a non-2xx HTTP response: status code,--- @Retry-After@ header (when integer-valued), and a snippet of the body--- (which also feeds context-overflow detection).-responseToError :: ResponseF LBS.ByteString -> BaikaiError-responseToError resp =-  BaikaiError-    { category = classifyHttpStatusWithBody status retryAfter body,-      message = msg,-      httpStatus = Just status,-      retryAfterSeconds = retryAfter,-      exitCode = Nothing-    }-  where-    status = statusCode (responseStatusCode resp)-    body = decodeLenient (LBS.toStrict (responseBody resp))-    retryAfter = parseRetryAfter (responseHeaders resp)-    snippet = Text.take 300 (Text.strip body)-    msg =-      "HTTP "-        <> Text.pack (show status)-        <> (if Text.null snippet then "" else ": " <> snippet)---- | Look up an integer @Retry-After@ header value (seconds). The HTTP--- date form is not parsed and yields 'Nothing'.-parseRetryAfter :: Seq (CI.CI ByteString, ByteString) -> Maybe Int-parseRetryAfter headers = do-  raw <- lookup (CI.mk "Retry-After") (toList headers)-  readMaybe (Text.unpack (Text.strip (decodeLenient raw)))--decodeLenient :: ByteString -> Text-decodeLenient = Text.decodeUtf8With Text.lenientDecode---- | Classify a mid-stream Anthropic @error@ event. The value is the--- inner error object, e.g. @{"type":"overloaded_error","message":"…"}@;--- it may also arrive wrapped under an @"error"@ key. Returns 'Nothing'--- when no error @type@ can be found (the caller keeps the plain text).-classifyErrorValue :: Value -> Maybe BaikaiError-classifyErrorValue v = do-  let obj = unwrap v-  ty <- stringField "type" obj-  let detail = maybe ty id (stringField "message" obj)-      cat = anthropicTypeToCategory ty detail-  Just (providerError detail) {category = cat}-  where-    unwrap (Object o) = case KeyMap.lookup "error" o of-      Just (Object inner) -> inner-      _ -> o-    unwrap _ = KeyMap.empty-    stringField k o = case KeyMap.lookup k o of-      Just (String t) -> Just t-      _ -> Nothing---- | Map an Anthropic error @type@ string (plus its message, for the--- overflow special case) to a category.-anthropicTypeToCategory :: Text -> Text -> ErrorCategory-anthropicTypeToCategory ty detail = case ty of-  "authentication_error" -> AuthError-  "permission_error" -> AuthError-  "rate_limit_error" -> RateLimited-  "overloaded_error" -> TransientError-  "api_error" -> TransientError-  "timeout_error" -> TransientError-  "not_found_error" -> InvalidRequest-  "request_too_large" -> ContextOverflow-  "invalid_request_error"-    | bodyIndicatesOverflow detail -> ContextOverflow-    | otherwise -> InvalidRequest-  _-    | bodyIndicatesOverflow detail -> ContextOverflow-    | otherwise -> OtherError

@@ -6,7 +6,9 @@ -- batch completion provider, while this module starts the interactive -- terminal UI and returns only after the CLI exits. module Baikai.Provider.Claude.Interactive-  ( ClaudeInteractiveConfig (..),+  ( ClaudeInteractiveConfig,+    executable,+    extraArgs,     defaultClaudeInteractiveConfig,     claudeInteractiveCommand,     launchClaudeInteractive,@@ -14,22 +16,21 @@ where  import Baikai.Interactive-  ( InteractiveLaunchRequest (..),+  ( InteractiveLaunchRequest,     InteractiveLaunchResult,     InteractiveProvider (..),     InteractiveSafety (..),-    _InteractiveLaunchResult,+    interactiveLaunchResult,   ) import Baikai.Prelude import Cradle (addArgs, cmd, run, setWorkingDir) import Data.Generics.Labels () import Data.Text qualified as Text-import Data.Vector qualified as Vector  -- | Configuration for the interactive @claude@ process. data ClaudeInteractiveConfig = ClaudeInteractiveConfig   { executable :: !FilePath,-    extraArgs :: !(Vector Text)+    extraArgs :: ![Text]   }   deriving stock (Eq, Show, Generic) @@ -42,7 +43,8 @@  -- | Render the executable and arguments for an interactive Claude -- Code launch. The final positional argument is the initial user--- prompt.+-- prompt. The prompt is preceded by @--@ because Claude's+-- @--allowedTools@ and @--add-dir@ flags are variadic. claudeInteractiveCommand ::   ClaudeInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String]) claudeInteractiveCommand cfg req =@@ -51,9 +53,9 @@       <> systemPromptArgs req       <> extraDirArgs req       <> safetyArgs req-      <> fmap Text.unpack (Vector.toList (cfg ^. #extraArgs))+      <> fmap Text.unpack (cfg ^. #extraArgs)       <> fmap Text.unpack (req ^. #extraArgs)-      <> [Text.unpack (req ^. #userPrompt)]+      <> ["--", Text.unpack (req ^. #userPrompt)]   )  -- | Launch Claude Code with inherited stdin, stdout, and stderr so@@ -67,10 +69,10 @@       cmd exe         & addArgs args         & maybe id setWorkingDir (req ^. #workingDir)-  pure (_InteractiveLaunchResult InteractiveClaude code)+  pure (interactiveLaunchResult InteractiveClaude code)  modelArgs :: InteractiveLaunchRequest -> [String]-modelArgs req = case Text.strip <$> req ^. #model of+modelArgs req = case Text.strip <$> req ^. #modelId of   Nothing -> []   Just "" -> []   Just mid -> ["--model", Text.unpack mid]

@@ -0,0 +1,168 @@+-- | Internal failure classification for the Anthropic provider.+--+-- This module is exposed for provider tests and debugging, but it is+-- not part of baikai's PVP-stable application surface. Names, types,+-- and semantics here may change in minor releases.+--+-- Two entry points cover the two ways a failure reaches the provider:+-- 'classifyException' for an exception thrown by the @servant-client@+-- HTTP layer, and 'classifyErrorValue' for an Anthropic @error@ event+-- that arrives mid-stream as a JSON 'Value'.+module Baikai.Provider.Claude.Internal.ErrorClass+  ( classifyException,+    classifyErrorText,+    classifyErrorValue,+    -- | Exposed for testing the HTTP-status mapping without a live call.+    responseToError,+  )+where++import Baikai.Error+  ( BaikaiError (..),+    ErrorCategory (..),+    bodyIndicatesOverflow,+    decodeError,+    httpError,+    invalidRequest,+    parseRetryAfterSeconds,+    providerError,+  )+import Control.Exception (SomeException, displayException, fromException)+import Data.Aeson (Value (..))+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.CaseInsensitive qualified as CI+import Data.Foldable (toList)+import Data.Sequence (Seq)+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 Network.HTTP.Client qualified as HTTP+import Network.HTTP.Types.Status (statusCode)+import Servant.Client (ClientError, ResponseF (..))+import Servant.Client qualified as Servant+import Text.Read (readMaybe)++-- | Convert any exception caught from the Anthropic SDK into a+-- categorised 'BaikaiError'. Recognises @servant-client@ 'ClientError'+-- and raw @http-client@ 'HttpException'; anything else degrades to a+-- generic provider error carrying the displayed exception text.+classifyException :: SomeException -> BaikaiError+classifyException ex+  | Just clientErr <- fromException ex = fromClientError clientErr+  | Just httpEx <- fromException ex = fromHttpException httpEx+  | otherwise = providerError (Text.pack (displayException ex))++fromClientError :: ClientError -> BaikaiError+fromClientError clientErr = case clientErr of+  Servant.FailureResponse _req resp -> responseToError resp+  Servant.DecodeFailure detail _ -> decodeError detail+  Servant.UnsupportedContentType _ _ -> decodeError "unsupported content type in Anthropic response"+  Servant.InvalidContentTypeHeader _ -> decodeError "invalid content-type header in Anthropic response"+  Servant.ConnectionError exc ->+    (providerError ("connection error: " <> Text.pack (displayException exc)))+      { category = TransientError+      }++-- | Build a 'BaikaiError' from a non-2xx HTTP response: status code,+-- @Retry-After@ header (when integer-valued), and a snippet of the body+-- (which also feeds context-overflow detection).+responseToError :: ResponseF LBS.ByteString -> BaikaiError+responseToError resp = httpError status retryAfter body+  where+    status = statusCode (responseStatusCode resp)+    body = decodeLenient (LBS.toStrict (responseBody resp))+    retryAfter = parseRetryAfter (responseHeaders resp)++-- | Look up an integer @Retry-After@ header value (seconds). The HTTP+-- date form is not parsed and yields 'Nothing'.+parseRetryAfter :: Seq (CI.CI ByteString, ByteString) -> Maybe Int+parseRetryAfter headers = do+  raw <- lookup (CI.mk "Retry-After") (toList headers)+  parseRetryAfterSeconds (decodeLenient raw)++fromHttpException :: HTTP.HttpException -> BaikaiError+fromHttpException = \case+  HTTP.InvalidUrlException url reason ->+    invalidRequest (Text.pack (url <> ": " <> reason))+  HTTP.HttpExceptionRequest _ content -> fromHttpExceptionContent content++fromHttpExceptionContent :: HTTP.HttpExceptionContent -> BaikaiError+fromHttpExceptionContent = \case+  HTTP.StatusCodeException resp body ->+    httpError+      (statusCode (HTTP.responseStatus resp))+      (parseRetryAfterHttp (HTTP.responseHeaders resp))+      (decodeLenient body)+  HTTP.ConnectionFailure e -> transient (Text.pack (displayException e))+  HTTP.ConnectionTimeout -> transient "connection timeout"+  HTTP.ResponseTimeout -> transient "response timeout"+  HTTP.ConnectionClosed -> transient "connection closed"+  HTTP.NoResponseDataReceived -> transient "no response data received"+  HTTP.IncompleteHeaders -> transient "incomplete response headers"+  other -> providerError (Text.pack (show other))+  where+    transient t = (providerError ("connection error: " <> t)) {category = TransientError}++parseRetryAfterHttp :: [(CI.CI ByteString, ByteString)] -> Maybe Int+parseRetryAfterHttp headers = do+  raw <- lookup (CI.mk "Retry-After") headers+  parseRetryAfterSeconds (decodeLenient raw)++decodeLenient :: ByteString -> Text+decodeLenient = Text.decodeUtf8With Text.lenientDecode++-- | Classify a mid-stream Anthropic @error@ event. The value is the+-- inner error object, e.g. @{"type":"overloaded_error","message":"…"}@;+-- it may also arrive wrapped under an @"error"@ key. Returns 'Nothing'+-- when no error @type@ can be found (the caller keeps the plain text).+classifyErrorValue :: Value -> Maybe BaikaiError+classifyErrorValue v = do+  let obj = unwrap v+  ty <- stringField "type" obj+  let detail = maybe ty id (stringField "message" obj)+      cat = anthropicTypeToCategory ty detail+  Just (providerError detail) {category = cat}+  where+    unwrap (Object o) = case KeyMap.lookup "error" o of+      Just (Object inner) -> inner+      _ -> o+    unwrap _ = KeyMap.empty+    stringField k o = case KeyMap.lookup k o of+      Just (String t) -> Just t+      _ -> Nothing++-- | Recover HTTP classification from the text shape emitted by the+-- upstream SDK's non-2xx path. The local SSE transport preserves+-- headers and should be preferred; this is a defense-in-depth parser.+classifyErrorText :: Text -> Maybe BaikaiError+classifyErrorText raw = do+  rest <- Text.stripPrefix "HTTP error " raw+  let (codeText, afterCode) = Text.breakOn " " rest+  code <- readMaybe (Text.unpack codeText)+  let body = case Text.breakOn ": " afterCode of+        (_, sepBody)+          | not (Text.null sepBody) -> Text.drop 2 sepBody+        _ -> ""+  pure (httpError code Nothing body)++-- | Map an Anthropic error @type@ string (plus its message, for the+-- overflow special case) to a category.+anthropicTypeToCategory :: Text -> Text -> ErrorCategory+anthropicTypeToCategory ty detail = case ty of+  "authentication_error" -> AuthError+  "permission_error" -> AuthError+  "rate_limit_error" -> RateLimited+  "overloaded_error" -> TransientError+  "api_error" -> TransientError+  "timeout_error" -> TransientError+  "not_found_error" -> InvalidRequest+  "request_too_large" -> ContextOverflow+  "invalid_request_error"+    | bodyIndicatesOverflow detail -> ContextOverflow+    | otherwise -> InvalidRequest+  _+    | bodyIndicatesOverflow detail -> ContextOverflow+    | otherwise -> OtherError

@@ -0,0 +1,324 @@+{-# LANGUAGE LambdaCase #-}++-- | Internal request mapping for the Anthropic Messages provider.+--+-- This module is exposed for provider tests and debugging but is not covered by PVP+-- compatibility guarantees. Import the public provider module for stable application code.+module Baikai.Provider.Claude.Internal.Request+  ( mapRequest,+    ThinkingPlan (..),+    computeThinking,+  )+where++import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Compat (AnthropicMessagesCompat (..), AnthropicThinkingStyle (..))+import Baikai.Content qualified as Content+import Baikai.Context (Context (..))+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.Tool qualified as Tool+import Claude.V1.Messages qualified as Messages+import Claude.V1.Tool qualified as ClaudeTool+import Control.Lens ((^.))+import Data.Aeson ((.=))+import Data.Aeson qualified as Aeson+import Data.ByteString.Base64 qualified as Base64+import Data.Char (isAlphaNum, isAscii)+import Data.Generics.Labels ()+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import Numeric.Natural (Natural)++-- ============================================================+-- Request mapping (preserved from EP-2 with minor refactoring to+-- accept Context/Options directly).+-- ============================================================++mapRequest :: Model -> Context -> Options -> Either Text Messages.CreateMessage+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+      maxTokensField_ = case budget plan of+        Just b -> clamp (baseTokens + b)+        Nothing -> clamp baseTokens+      cacheControlField = computeCacheControl compat (opts ^. #cacheRetention)+      toolsVec = ctx ^. #tools+      toolsField =+        if Vector.null toolsVec+          then Nothing+          else Just (Vector.map (mkAnthropicTool compat) toolsVec)+      toolChoiceField = case opts ^. #toolChoice of+        Just Tool.ToolChoiceNone -> Nothing+        Just tc -> Just (mkAnthropicToolChoice tc)+        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+      }++mergeEffort :: Maybe Text -> Maybe Messages.OutputConfig -> Maybe Messages.OutputConfig+mergeEffort Nothing cfg = cfg+mergeEffort (Just e) Nothing = Just (Messages.effortConfig e)+mergeEffort (Just e) (Just cfg) = Just cfg {Messages.effort = Just e}++-- | Map a baikai 'ResponseFormat' onto the upstream Anthropic+-- 'Messages.OutputConfig'. 'JsonSchema' forwards the schema+-- verbatim via 'Messages.jsonSchemaConfig'. Anthropic's structured+-- outputs are always schema-enforcing, so the baikai 'strict' flag+-- has no wire analog and is dropped. 'JsonObject' (plain-JSON mode)+-- has no native Anthropic equivalent — 'output_config' requires a+-- schema — so it downgrades to a permissive @{"type":"object"}@+-- schema, which still forces the model to emit a JSON object.+mkAnthropicOutputConfig :: ResponseFormat -> Messages.OutputConfig+mkAnthropicOutputConfig = \case+  JsonSchema {schema = s} -> Messages.jsonSchemaConfig s+  JsonObject ->+    Messages.jsonSchemaConfig+      (Aeson.object ["type" .= ("object" :: Text)])++-- | Translate the call-time 'Baikai.CacheRetention' preference into+-- the Anthropic SDK's @cache_control@ shape.+--+-- 'CacheRetentionNone' (and 'Nothing') turn the field off entirely.+-- 'CacheRetentionShort' uses the ephemeral marker with no TTL (the+-- provider default). 'CacheRetentionLong' asks for the @"1h"@ TTL+-- when the host advertises 'supportsLongCacheRetention'; otherwise it+-- transparently downgrades to short retention.+computeCacheControl ::+  AnthropicMessagesCompat ->+  Maybe CacheRetention ->+  Maybe Messages.CacheControl+computeCacheControl _ Nothing = Nothing+computeCacheControl _ (Just CacheRetentionNone) = Nothing+computeCacheControl _ (Just CacheRetentionShort) =+  Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing}+computeCacheControl compat (Just CacheRetentionLong)+  | supportsLongCacheRetention compat =+      Just+        Messages.CacheControl+          { Messages.type_ = "ephemeral",+            Messages.ttl = Just (Messages.CacheTTLDuration "1h")+          }+  | otherwise =+      Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing}++-- | Translate the call-time 'Baikai.ThinkingLevel' preference into+-- the Anthropic SDK's 'Messages.Thinking' shape.+--+-- We only enable the thinking field when the chosen model advertises+-- 'reasoning' support — sending a thinking config to a non-reasoning+-- model is a 400 error from Anthropic, not a silent no-op. Callers+-- that asked for thinking on a non-reasoning model get the request+-- shaped without it (the request still succeeds and returns a normal+-- response).+data ThinkingPlan = ThinkingPlan+  { field :: !(Maybe Messages.Thinking),+    effort :: !(Maybe Text),+    budget :: !(Maybe Natural)+  }+  deriving stock (Eq, Show, Generic)++emptyThinkingPlan :: ThinkingPlan+emptyThinkingPlan =+  ThinkingPlan+    { field = Nothing,+      effort = Nothing,+      budget = Nothing+    }++computeThinking ::+  AnthropicMessagesCompat ->+  Model ->+  Maybe ThinkingLevel ->+  ThinkingPlan+computeThinking _ _ Nothing = emptyThinkingPlan+computeThinking compat m (Just lvl)+  | not (m ^. #reasoning) = emptyThinkingPlan+  | thinkingStyle compat == AnthropicThinkingAdaptive =+      ThinkingPlan+        { field = Just Messages.ThinkingAdaptive,+          effort = adaptiveEffort lvl,+          budget = Nothing+        }+  | otherwise =+      let b = thinkingTokenBudget lvl+       in ThinkingPlan+            { field = Just Messages.ThinkingEnabled {Messages.budget_tokens = b},+              effort = Nothing,+              budget = Just b+            }++adaptiveEffort :: ThinkingLevel -> Maybe Text+adaptiveEffort = \case+  ThinkingMinimal -> Just "low"+  ThinkingLow -> Just "low"+  ThinkingMedium -> Just "medium"+  ThinkingHigh -> Nothing++-- | Map a baikai 'Tool.Tool' into the upstream Anthropic+-- 'ClaudeTool.ToolDefinition'. The SDK helper is used to populate+-- the ordinary typed fields; the raw request shaper later restores+-- the caller's verbatim @input_schema@ because+-- 'ClaudeTool.functionTool' keeps only a subset of JSON Schema.+--+-- The compat record is accepted at this layer for call-site+-- consistency; per-tool @cache_control@ markers are applied by+-- 'Baikai.Provider.Claude.Shape.injectToolCacheControl'.+mkAnthropicTool :: AnthropicMessagesCompat -> Tool.Tool -> ClaudeTool.ToolDefinition+mkAnthropicTool _compat t =+  ClaudeTool.inlineTool+    ( ClaudeTool.functionTool+        (Tool.name t)+        (Just (Tool.description t))+        (Tool.parameters t)+    )++-- | Map a baikai 'Tool.ToolChoice' into the upstream Anthropic+-- 'ClaudeTool.ToolChoice'. 'Tool.ToolChoiceNone' is handled by the+-- raw request shaper because the SDK lacks a @none@ constructor.+-- 'Tool.ToolChoiceRequired' maps to Anthropic's+-- @any@ which is the closest equivalent ("must call some tool").+mkAnthropicToolChoice :: Tool.ToolChoice -> ClaudeTool.ToolChoice+mkAnthropicToolChoice = \case+  Tool.ToolChoiceAuto -> ClaudeTool.ToolChoice_Auto+  Tool.ToolChoiceRequired -> ClaudeTool.ToolChoice_Any+  Tool.ToolChoiceSpecific n -> ClaudeTool.ToolChoice_Tool {ClaudeTool.name = n}+  -- Unreachable in typed requests: ToolChoiceNone is injected by the shaper.+  Tool.ToolChoiceNone -> ClaudeTool.ToolChoice_Auto++-- | Anthropic enforces @[a-zA-Z0-9_-]+@ on tool-call ids and caps+-- their length at 64 characters. Callers may have used any+-- naming convention, so the provider boundary normalizes here+-- whenever an id is round-tripped back to Anthropic — both on+-- assistant turn replay ('Content_Tool_Use') and on tool-result+-- messages ('Content_Tool_Result').+normalizeToolCallId :: Text -> Text+normalizeToolCallId =+  Text.take 64 . Text.map sanitise+  where+    sanitise c+      | isAscii c && isAlphaNum c = c+      | c == '_' || c == '-' = c+      | otherwise = '_'++mapMessage :: Msg.Message -> Either Text Messages.Message+mapMessage = \case+  Msg.UserMessage Msg.UserPayload {Msg.content = uc} ->+    Right+      Messages.Message+        { Messages.role = Messages.User,+          Messages.content = Vector.mapMaybe userContentToBlock uc,+          Messages.cache_control = Nothing+        }+  Msg.AssistantMessage Msg.AssistantPayload {Msg.content = ac} ->+    Right+      Messages.Message+        { Messages.role = Messages.Assistant,+          Messages.content = Vector.mapMaybe assistantContentToBlock ac,+          Messages.cache_control = Nothing+        }+  Msg.ToolResultMessage+    Msg.ToolResultPayload+      { Msg.toolCallId = tid,+        Msg.content = trc,+        Msg.isError = err+      } ->+      case concatToolResultText trc of+        Left unsupported -> Left unsupported+        Right body ->+          Right+            Messages.Message+              { Messages.role = Messages.User,+                Messages.content =+                  Vector.singleton+                    Messages.Content_Tool_Result+                      { Messages.tool_use_id = normalizeToolCallId tid,+                        Messages.content = nonEmpty body,+                        Messages.is_error = Just err+                      },+                Messages.cache_control = Nothing+              }++userContentToBlock :: Content.UserContent -> Maybe Messages.Content+userContentToBlock = \case+  Content.UserText (Content.TextContent t) ->+    Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing}+  Content.UserImage img ->+    Just+      Messages.Content_Image+        { Messages.source =+            Messages.ImageSource+              { Messages.type_ = "base64",+                Messages.media_type = Content.mimeType img,+                Messages.data_ = Text.decodeUtf8 (Base64.encode (Content.imageData img))+              },+          Messages.cache_control = Nothing+        }++assistantContentToBlock :: Content.AssistantContent -> Maybe Messages.Content+assistantContentToBlock = \case+  Content.AssistantText (Content.TextContent t) ->+    Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing}+  Content.AssistantThinking th ->+    if Content.redacted th+      then Just Messages.Content_Redacted_Thinking {Messages.data_ = Content.thinking th}+      else case Content.signature th of+        Just sig ->+          Just+            Messages.Content_Thinking+              { Messages.thinking = Content.thinking th,+                Messages.signature = sig+              }+        Nothing -> Nothing+  Content.AssistantToolCall tc ->+    Just+      Messages.Content_Tool_Use+        { Messages.id = normalizeToolCallId (Content.id_ tc),+          Messages.name = Content.name tc,+          Messages.input = Content.arguments tc,+          Messages.caller = Nothing+        }++concatToolResultText :: Vector Content.ToolResultContent -> Either Text Text+concatToolResultText =+  fmap (Text.concat . Vector.toList) . traverse oneBlock+  where+    oneBlock = \case+      Content.ToolResultText (Content.TextContent t) -> Right t+      Content.ToolResultImage _ ->+        Left "Anthropic Messages cannot encode ToolResultImage blocks in tool-result messages"++nonEmpty :: Text -> Maybe Text+nonEmpty t+  | Text.null t = Nothing+  | otherwise = Just t

@@ -0,0 +1,129 @@+{-# LANGUAGE LambdaCase #-}++-- | Pure request-body shaping for Anthropic-compatible Messages hosts.+module Baikai.Provider.Claude.Shape+  ( shapeRequestBody,+    streamRequestBody,+    replaceToolSchemas,+    injectToolChoiceNone,+    injectToolCacheControl,+  )+where++import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Compat (AnthropicMessagesCompat (supportsCacheControlOnTools, supportsLongCacheRetention))+import Baikai.Context (Context, tools)+import Baikai.Options (Options, cacheRetention, toolChoice)+import Baikai.Tool qualified as Tool+import Claude.V1.Messages qualified as Messages+import Data.Aeson (Value (..), (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as AesonKey+import Data.Aeson.KeyMap (KeyMap)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text (Text)+import Data.Vector qualified as Vector++shapeRequestBody ::+  AnthropicMessagesCompat ->+  Context ->+  Options ->+  Aeson.Value ->+  Aeson.Value+shapeRequestBody compat ctx opts =+  injectToolCacheControl compat opts+    . injectToolChoiceNone opts+    . replaceToolSchemas ctx++streamRequestBody ::+  AnthropicMessagesCompat ->+  Context ->+  Options ->+  Messages.CreateMessage ->+  Aeson.Value+streamRequestBody compat ctx opts req =+  shapeRequestBody compat ctx opts (Aeson.toJSON req {Messages.stream = Just True})++replaceToolSchemas :: Context -> Aeson.Value -> Aeson.Value+replaceToolSchemas ctx+  | Vector.null toolsVec = id+  | otherwise =+      mapObject $+        adjustKey (key "tools") $+          mapTools (Vector.toList toolsVec)+  where+    toolsVec = tools ctx++injectToolChoiceNone :: Options -> Aeson.Value -> Aeson.Value+injectToolChoiceNone opts+  | Just Tool.ToolChoiceNone <- toolChoice opts =+      mapObject (KeyMap.insert (key "tool_choice") (Aeson.object ["type" .= ("none" :: Text)]))+  | otherwise = id++injectToolCacheControl :: AnthropicMessagesCompat -> Options -> Aeson.Value -> Aeson.Value+injectToolCacheControl compat opts body =+  case (supportsCacheControlOnTools compat, cacheRetention opts) of+    (True, Just retention)+      | Just marker <- cacheControlMarker compat retention ->+          mapObject (adjustKey (key "tools") (markLastTool marker)) body+    _ -> body++mapTools :: [Tool.Tool] -> Aeson.Value -> Aeson.Value+mapTools toolDefs = \case+  Array toolsJson ->+    Array (Vector.imap patchTool toolsJson)+  other -> other+  where+    patchTool i =+      case drop i toolDefs of+        t : _ -> replaceInputSchema (Tool.parameters t)+        [] -> id++replaceInputSchema :: Aeson.Value -> Aeson.Value -> Aeson.Value+replaceInputSchema schema =+  mapObject (KeyMap.insert (key "input_schema") schema)++markLastTool :: Aeson.Value -> Aeson.Value -> Aeson.Value+markLastTool marker = \case+  Array toolsJson+    | not (Vector.null toolsJson) ->+        let i = Vector.length toolsJson - 1+         in Array (toolsJson Vector.// [(i, markTool marker (toolsJson Vector.! i))])+  other -> other++markTool :: Aeson.Value -> Aeson.Value -> Aeson.Value+markTool marker =+  mapObject (KeyMap.insert (key "cache_control") marker)++cacheControlMarker :: AnthropicMessagesCompat -> CacheRetention -> Maybe Aeson.Value+cacheControlMarker compat = \case+  CacheRetentionNone -> Nothing+  CacheRetentionShort -> Just (Aeson.object ["type" .= ("ephemeral" :: Text)])+  CacheRetentionLong ->+    if supportsLongCacheRetention compat+      then+        Just+          ( Aeson.object+              [ "type" .= ("ephemeral" :: Text),+                "ttl" .= ("1h" :: Text)+              ]+          )+      else Just (Aeson.object ["type" .= ("ephemeral" :: Text)])++mapObject :: (KeyMap Aeson.Value -> KeyMap Aeson.Value) -> Aeson.Value -> Aeson.Value+mapObject f = \case+  Object obj -> Object (f obj)+  other -> other++adjustKey ::+  AesonKey.Key ->+  (Aeson.Value -> Aeson.Value) ->+  KeyMap Aeson.Value ->+  KeyMap Aeson.Value+adjustKey k f obj =+  case KeyMap.lookup k obj of+    Nothing -> obj+    Just old -> KeyMap.insert k (f old) obj++key :: Text -> AesonKey.Key+key = AesonKey.fromText

@@ -0,0 +1,172 @@+{-# LANGUAGE LambdaCase #-}++-- | Local SSE transport for Anthropic Messages streams.+--+-- The upstream @claude@ SDK exposes the right event decoder, but its+-- non-2xx path collapses status, headers, and body into plain text. This+-- wrapper keeps the SDK's request and SSE parsing shape while surfacing+-- classified 'BaikaiError' values.+module Baikai.Provider.Claude.Sse+  ( claudeSseStream,+    claudeSseStreamValue,+    claudeSseStreamValueWithHeaders,+    sseFromResponse,+  )+where++import Baikai.Error (BaikaiError, decodeError, httpError, parseRetryAfterSeconds)+import Claude.V1.Messages qualified as Messages+import Control.Monad (foldM, when)+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as SBS+import Data.ByteString.Char8 qualified as S8+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 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++-- | 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'.+claudeSseStream ::+  Client.ClientEnv ->+  Text ->+  Maybe Text ->+  Messages.CreateMessage ->+  (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->+  IO ()+claudeSseStream env apiKey anthropicVersion req =+  claudeSseStreamValue env apiKey anthropicVersion (Aeson.toJSON req {Messages.stream = Just True})++claudeSseStreamValue ::+  Client.ClientEnv ->+  Text ->+  Maybe Text ->+  Aeson.Value ->+  (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->+  IO ()+claudeSseStreamValue env apiKey anthropicVersion =+  claudeSseStreamValueWithHeaders env requestHeaders+  where+    requestHeaders =+      maybe+        id+        (\v -> (("anthropic-version", Text.encodeUtf8 v) :))+        anthropicVersion+        [ ("x-api-key", Text.encodeUtf8 apiKey),+          ("Accept", "text/event-stream"),+          ("Content-Type", "application/json")+        ]++claudeSseStreamValueWithHeaders ::+  Client.ClientEnv ->+  RequestHeaders ->+  Aeson.Value ->+  (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->+  IO ()+claudeSseStreamValueWithHeaders env requestHeaders requestBody onEvent = do+  let base = Client.baseUrl env+      secure = case Client.baseUrlScheme base of+        Client.Http -> False+        Client.Https -> True+      request =+        HTTP.defaultRequest+          { HTTP.secure = secure,+            HTTP.host = S8.pack (Client.baseUrlHost base),+            HTTP.port = Client.baseUrlPort base,+            HTTP.method = "POST",+            HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> "/v1/messages"),+            HTTP.requestHeaders = requestHeaders,+            HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode requestBody),+            -- EP-8 wires Options.timeoutMs through this local transport.+            HTTP.responseTimeout = HTTP.responseTimeoutNone+          }+  HTTP.withResponse request (Client.manager env) (`sseFromResponse` onEvent)++-- | Consume an @http-client@ response as an Anthropic SSE stream.+sseFromResponse ::+  HTTP.Response HTTP.BodyReader ->+  (Either BaikaiError Messages.MessageStreamEvent -> IO ()) ->+  IO ()+sseFromResponse response onEvent = do+  let st = HTTP.responseStatus response+  if not (Status.statusIsSuccessful st)+    then do+      bodyChunks <- HTTP.brConsume (HTTP.responseBody response)+      let bodyText = decodeLenient (SBS.concat bodyChunks)+          retryAfter =+            parseRetryAfterSeconds . decodeLenient+              =<< lookup (CI.mk "Retry-After") (HTTP.responseHeaders response)+      onEvent (Left (httpError (Status.statusCode st) retryAfter bodyText))+    else do+      lineBufRef <- IORef.newIORef SBS.empty+      eventBufRef <- IORef.newIORef ([] :: [SBS.ByteString])+      let flushEvent = do+            es <- IORef.atomicModifyIORef' eventBufRef (\buf -> ([], reverse buf))+            case es of+              [] -> pure False+              _ -> do+                let payload = S8.concat es+                case Aeson.eitherDecodeStrict payload of+                  Left err -> onEvent (Left (decodeError (Text.pack err))) >> pure False+                  Right val -> case Aeson.fromJSON val of+                    Aeson.Error err -> onEvent (Left (decodeError (Text.pack err))) >> pure False+                    Aeson.Success ev -> onEvent (Right ev) >> pure False++          handleLine line =+            let l = stripCR line+             in if S8.null l+                  then flushEvent+                  else+                    if "data:" `S8.isPrefixOf` l+                      then do+                        let d = S8.dropWhile (== ' ') (S8.drop 5 l)+                        IORef.modifyIORef' eventBufRef (d :)+                        pure False+                      else pure False++          loop = do+            chunk <- HTTP.brRead (HTTP.responseBody response)+            if SBS.null chunk+              then do+                pendingLine <- IORef.readIORef lineBufRef+                when (not (SBS.null pendingLine)) $ do+                  _ <- handleLine pendingLine+                  IORef.writeIORef lineBufRef SBS.empty+                _ <- flushEvent+                pure ()+              else do+                prev <- IORef.readIORef lineBufRef+                let combined = prev <> chunk+                    ls = S8.split '\n' combined+                case unsnoc ls of+                  Nothing -> loop+                  Just (completeLines, lastLine) -> do+                    IORef.writeIORef lineBufRef lastLine+                    stop <- foldM (\acc ln -> if acc then pure True else handleLine ln) False completeLines+                    if stop then pure () else loop+      loop++normalizePath :: String -> String+normalizePath = \case+  "" -> ""+  p@('/' : _) -> p+  p -> '/' : p++stripCR :: SBS.ByteString -> SBS.ByteString+stripCR bs = case S8.unsnoc bs of+  Just (initBs, '\r') -> initBs+  _ -> bs++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc xs = Just (init xs, last xs)++decodeLenient :: SBS.ByteString -> Text+decodeLenient = Text.decodeUtf8With Text.lenientDecode

@@ -0,0 +1,164 @@+module Baikai.Provider.Claude.Transport+  ( getClientEnvCached,+    cachedClientEnvCount,+    requestHeaders,+    resolveKey,+    runWithTimeout,+    sessionAffinityValue,+  )+where++import Baikai.Auth qualified as Auth+import Baikai.Compat (AnthropicMessagesCompat (..))+import Baikai.Content qualified as Content+import Baikai.Context (Context (..))+import Baikai.Error (BaikaiError (..), ErrorCategory (..), authError)+import Baikai.Message qualified as Msg+import Baikai.Model (Model (..))+import Baikai.Options (Options (..))+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)+import Control.Exception (throwIO)+import Control.Lens ((^.))+import Crypto.Hash (Digest, SHA256)+import Crypto.Hash qualified as Hash+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Vector qualified as Vector+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Client.TLS qualified as TLS+import Network.HTTP.Types.Header (RequestHeaders)+import Servant.Client qualified as Client+import System.IO.Unsafe (unsafePerformIO)+import System.Timeout qualified as Timeout++getClientEnvCached :: Text -> IO Client.ClientEnv+getClientEnvCached baseUrl =+  modifyMVar clientEnvCache $ \cache ->+    case Map.lookup baseUrl cache of+      Just env -> pure (cache, env)+      Nothing -> do+        env <- newClientEnv baseUrl+        pure (Map.insert baseUrl env cache, env)++cachedClientEnvCount :: IO Int+cachedClientEnvCount =+  modifyMVar clientEnvCache $ \cache -> pure (cache, Map.size cache)++requestHeaders ::+  Text ->+  Maybe Text ->+  AnthropicMessagesCompat ->+  Context ->+  Model ->+  Options ->+  RequestHeaders+requestHeaders apiKey anthropicVersion compat ctx m opts =+  applyHeaderOverrides providerHeaders (Map.toList (m ^. #headers) <> Map.toList (opts ^. #headers))+  where+    providerHeaders =+      maybe+        id+        (\v -> (("anthropic-version", Text.encodeUtf8 v) :))+        anthropicVersion+        ( sessionHeaders+            <> [ ("x-api-key", Text.encodeUtf8 apiKey),+                 ("Accept", "text/event-stream"),+                 ("Content-Type", "application/json")+               ]+        )+    sessionHeaders =+      if sendSessionAffinityHeaders compat+        then [("x-session-affinity", Text.encodeUtf8 (sessionAffinityValue ctx))]+        else []++resolveKey :: Text -> Options -> IO Text+resolveKey baseUrl opts = case opts ^. #apiKey of+  Just source -> Auth.resolveApiKey source+  Nothing -> case Auth.defaultApiKeyEnvForBaseUrl baseUrl of+    Just name -> Auth.resolveApiKey (Auth.ApiKeyEnv name)+    Nothing ->+      throwIO $+        authError $+          "no default API key env is known for " <> baseUrl <> "; set Options.apiKey explicitly"++runWithTimeout :: Maybe Int -> IO () -> IO (Maybe BaikaiError)+runWithTimeout Nothing action = action >> pure Nothing+runWithTimeout (Just ms) action = do+  result <- Timeout.timeout (max 0 ms * 1000) action+  pure $ case result of+    Just () -> Nothing+    Nothing -> Just (timeoutError ms)++sessionAffinityValue :: Context -> Text+sessionAffinityValue ctx =+  let digest = Hash.hash (Text.encodeUtf8 (affinitySeed ctx)) :: Digest SHA256+   in Text.pack (show digest)++affinitySeed :: Context -> Text+affinitySeed ctx =+  Text.intercalate+    "\n"+    [ maybe "" id (ctx ^. #systemPrompt),+      firstUserText (ctx ^. #messages)+    ]++firstUserText :: Vector.Vector Msg.Message -> Text+firstUserText =+  maybe "" id . foldr firstText Nothing . Vector.toList+  where+    firstText msg acc =+      case msg of+        Msg.UserMessage Msg.UserPayload {Msg.content = content} ->+          case firstTextContent content of+            Just t -> Just t+            Nothing -> acc+        _ -> acc++firstTextContent :: Vector.Vector Content.UserContent -> Maybe Text+firstTextContent =+  foldr firstText Nothing . Vector.toList+  where+    firstText block acc =+      case block of+        Content.UserText Content.TextContent {Content.text = t} -> Just t+        _ -> acc++timeoutError :: Int -> BaikaiError+timeoutError ms =+  BaikaiError+    { category = TransientError,+      message = "provider stream exceeded timeoutMs=" <> Text.pack (show ms),+      httpStatus = Nothing,+      retryAfterSeconds = Nothing,+      exitCode = Nothing+    }++newClientEnv :: Text -> IO Client.ClientEnv+newClientEnv baseUrl = do+  parsed <- Client.parseBaseUrl (Text.unpack baseUrl)+  manager <-+    TLS.newTlsManagerWith+      TLS.tlsManagerSettings+        { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone+        }+  pure (Client.mkClientEnv manager parsed)++applyHeaderOverrides ::+  RequestHeaders ->+  [(Text, Text)] ->+  RequestHeaders+applyHeaderOverrides =+  foldl addHeader+  where+    addHeader headers (name, value) =+      let nameBytes = Text.encodeUtf8 name+          ciName = CI.mk nameBytes+       in (ciName, Text.encodeUtf8 value) : filter ((/= ciName) . fst) headers++{-# NOINLINE clientEnvCache #-}+clientEnvCache :: MVar (Map.Map Text Client.ClientEnv)+clientEnvCache = unsafePerformIO (newMVar Map.empty)

@@ -1,8 +1,9 @@ module ErrorClassSpec (tests) where -import Baikai.Error (BaikaiError (..), ErrorCategory (..))-import Baikai.Provider.Claude.ErrorClass-  ( classifyErrorValue,+import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable)+import Baikai.Provider.Claude.Internal.ErrorClass+  ( classifyErrorText,+    classifyErrorValue,     classifyException,     responseToError,   )@@ -13,6 +14,7 @@ import Data.CaseInsensitive qualified as CI import Data.Sequence qualified as Seq import Data.Text qualified as Text+import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) import Servant.Client (ResponseF (..))@@ -22,8 +24,9 @@ tests :: TestTree tests =   testGroup-    "Baikai.Provider.Claude.ErrorClass"+    "Baikai.Provider.Claude.Internal.ErrorClass"     [ httpStatusTests,+      sdkTextTests,       streamedErrorTests,       fallbackTests     ]@@ -93,11 +96,46 @@ fallbackTests =   testGroup     "classifyException fallback"-    [ testCase "non-ClientError exception -> OtherError, text preserved" $ do+    [ testCase "http-client connection failures are transient" $ do+        let e =+              classifyException $+                toException $+                  HTTP.HttpExceptionRequest+                    HTTP.defaultRequest+                    (HTTP.ConnectionFailure (toException (userError "reset")))+        category e @?= TransientError+        assertBool "connection failure is retryable" (isRetryable e),+      testCase "http-client response timeouts are transient" $ do+        let e =+              classifyException $+                toException $+                  HTTP.HttpExceptionRequest+                    HTTP.defaultRequest+                    HTTP.ResponseTimeout+        category e @?= TransientError+        assertBool "response timeout is retryable" (isRetryable e),+      testCase "non-ClientError exception -> OtherError, text preserved" $ do         let e = classifyException (toException (userError "weird failure"))         category e @?= OtherError         assertBool "message keeps the original text" $           "weird failure" `Text.isInfixOf` message e+    ]++sdkTextTests :: TestTree+sdkTextTests =+  testGroup+    "classifyErrorText (SDK HTTP text)"+    [ testCase "429 text -> RateLimited" $ do+        let parsed =+              classifyErrorText+                "HTTP error 429 Too Many Requests: {\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"+        fmap category parsed @?= Just RateLimited+        fmap httpStatus parsed @?= Just (Just 429),+      testCase "529 text -> TransientError" $+        fmap category (classifyErrorText "HTTP error 529 ")+          @?= Just TransientError,+      testCase "non-matching text -> Nothing" $+        classifyErrorText "ordinary stream error" @?= Nothing     ]  -- | The inner error object Anthropic streams as the @error@ field.

@@ -2,8 +2,11 @@  import Baikai 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 Claude.V1.Messages qualified as Messages+import Control.Exception (bracket) import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson import Data.ByteString.Char8 qualified as BS8@@ -11,9 +14,17 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import ErrorClassSpec qualified+import ShapeSpec qualified+import SseSpec qualified import Streamly.Data.Stream qualified as Stream+import System.Directory (getPermissions, getTemporaryDirectory, setOwnerExecutable, setPermissions)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.FilePath ((</>))+import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))+import ThinkingSpec qualified+import TransportSpec qualified  main :: IO () main =@@ -21,10 +32,19 @@     testGroup       "Baikai.Provider.Claude"       [ commandRenderingTest,+        batchCommandRenderingTest,+        stderrFloodTest,         compatDetectionTest,         rejectsImageToolResultsTest,+        noKeyStreamTest,+        cliMissingBinaryTest,         responseFormatMappingTest,-        ErrorClassSpec.tests+        optionsMappingTest,+        ErrorClassSpec.tests,+        ShapeSpec.tests,+        SseSpec.tests,+        ThinkingSpec.tests,+        TransportSpec.tests       ]  -- | A 'JsonSchema' on 'Options.responseFormat' maps onto Anthropic's@@ -35,7 +55,7 @@ responseFormatMappingTest =   testCase "responseFormat JsonSchema maps onto Anthropic output_config" $ do     let model =-          _Model+          emptyModel             & #modelId .~ "claude-haiku-4-5-20251001"             & #api .~ AnthropicMessages             & #provider .~ "anthropic"@@ -50,9 +70,9 @@               "required" Aeson..= (["name", "age"] :: [Text.Text]),               "additionalProperties" Aeson..= False             ]-        ctx = _Context+        ctx = emptyContext         opts =-          _Options+          emptyOptions             & #responseFormat               .~ Just (JsonSchema {name = "person", schema = personSchema, strict = True})     case mapRequest model ctx opts of@@ -61,18 +81,39 @@         Messages.output_config req           @?= Just (Messages.jsonSchemaConfig personSchema) +optionsMappingTest :: TestTree+optionsMappingTest =+  testCase "sampling Options map onto Anthropic request fields" $ do+    let model =+          emptyModel+            & #modelId .~ "claude-haiku-4-5-20251001"+            & #api .~ AnthropicMessages+            & #provider .~ "anthropic"+        opts =+          emptyOptions+            & #topP .~ Just 0.9+            & #stopSequences .~ Just (Vector.fromList ["END", "STOP"])+            & #seed .~ Just 7+            & #frequencyPenalty .~ Just 0.2+            & #presencePenalty .~ Just 0.3+    case mapRequest model emptyContext opts of+      Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)+      Right req -> do+        Messages.top_p req @?= Just 0.9+        Messages.stop_sequences req @?= Just (Vector.fromList ["END", "STOP"])+ commandRenderingTest :: TestTree commandRenderingTest =   testCase "renders model, prompt, directories, allowed tools, and extra args" $ do     let cfg =           defaultClaudeInteractiveConfig             { executable = "/bin/claude",-              extraArgs = Vector.fromList ["--debug"]+              extraArgs = ["--debug"]             }         req =-          (_InteractiveLaunchRequest "inspect the repo")+          (interactiveLaunchRequest "inspect the repo")             & #systemPrompt .~ Just "Be terse."-            & #model .~ Just "sonnet"+            & #modelId .~ Just "sonnet"             & #workingDir .~ Just "/work/project"             & #extraDirs .~ ["/work/shared", "/work/docs"]             & #safety .~ ClaudeAllowedTools ["Read", "Bash(git status)"]@@ -92,15 +133,76 @@               "--debug",               "--permission-mode",               "plan",+              "--",               "inspect the repo"             ]           ) +batchCommandRenderingTest :: TestTree+batchCommandRenderingTest =+  testCase "claude -p argv terminates options before a dash-leading prompt" $ do+    let cfg =+          ClaudeCli.defaultClaudeCliConfig+            { ClaudeCli.executable = "/bin/claude",+              ClaudeCli.extraArgs = ["--allowedTools", "Read"]+            }+        model =+          emptyModel+            & #modelId .~ "sonnet"+            & #api .~ AnthropicMessagesCli+            & #provider .~ "anthropic"+        ctx =+          emptyContext+            & #systemPrompt .~ Just "Be terse."+            & #messages .~ Vector.singleton (user "-begin with a dash")+    ClaudeCli.claudeCliCommand cfg model ctx+      @?= ( "/bin/claude",+            [ "-p",+              "--model",+              "sonnet",+              "--output-format",+              "json",+              "--no-session-persistence",+              "--system-prompt",+              "Be terse.",+              "--allowedTools",+              "Read",+              "--",+              "-begin with a dash"+            ]+          )++stderrFloodTest :: TestTree+stderrFloodTest =+  testCase "claude batch provider survives a 1MiB stderr flood without deadlock" $ do+    dir <- getTemporaryDirectory+    let script = dir </> "baikai-claude-stderr-flood.sh"+    writeFile script $+      unlines+        [ "#!/bin/sh",+          "head -c 1048576 /dev/zero | tr '\\0' 'e' >&2",+          "printf '{\"result\":\"pong\",\"is_error\":false}\\n'"+        ]+    perms <- getPermissions script+    setPermissions script (setOwnerExecutable True perms)+    reg <- newProviderRegistry+    registerApiProviderWith reg (ClaudeCli.claudeCliProvider ClaudeCli.defaultClaudeCliConfig {ClaudeCli.executable = script})+    let model =+          emptyModel+            & #modelId .~ ""+            & #api .~ AnthropicMessagesCli+            & #provider .~ "anthropic"+        ctx = emptyContext & #messages .~ Vector.singleton (user "ping")+    mResp <- timeout 30000000 (completeRequestWith reg model ctx emptyOptions)+    case mResp of+      Nothing -> assertFailure "deadlock: stderr was not drained concurrently"+      Just resp -> assistantText resp @?= "pong"+ compatDetectionTest :: TestTree compatDetectionTest =   testCase "Anthropic-compatible hosts auto-detect request-shaping compat flags" $ do     let model =-          _Model+          emptyModel             & #api .~ AnthropicMessages             & #baseUrl .~ "https://api.fireworks.ai/inference/v1"         compat = anthropicMessagesCompatFor model@@ -112,13 +214,13 @@ rejectsImageToolResultsTest =   testCase "Claude API mapping rejects image tool-result blocks instead of dropping them" $ do     let model =-          _Model+          emptyModel             & #modelId .~ "claude-test"             & #api .~ AnthropicMessages             & #provider .~ "anthropic"         image = ImageContent {imageData = BS8.pack "png-bytes", mimeType = "image/png"}         ctx =-          _Context+          emptyContext             & #messages               .~ Vector.singleton                 ( ToolResultMessage@@ -127,13 +229,75 @@                         toolName = "render",                         content = Vector.singleton (ToolResultImage image),                         isError = False,-                        timestamp = read "2026-06-05 00:00:00 UTC"+                        timestamp = Just (read "2026-06-05 00:00:00 UTC")                       }                 )-    events <- Stream.toList (claudeMessagesStream model ctx _Options)+    events <- Stream.toList (claudeMessagesStream model ctx emptyOptions)+    assertErrorContract events     case events of-      [EventError TerminalPayload {message = AssistantMessage AssistantPayload {errorMessage = Just msg}}] ->-        assertBool-          ("expected ToolResultImage error, got: " <> Text.unpack msg)-          ("ToolResultImage" `Text.isInfixOf` msg)-      other -> error ("expected one EventError; got: " <> show other)+      [ EventStart StartPayload {},+        EventError TerminalPayload {message = AssistantMessage AssistantPayload {errorMessage = Just msg}}+        ] ->+          assertBool+            ("expected ToolResultImage error, got: " <> Text.unpack msg)+            ("ToolResultImage" `Text.isInfixOf` msg)+      other -> error ("expected EventStart then EventError; got: " <> show other)++noKeyStreamTest :: TestTree+noKeyStreamTest =+  testCase "missing ANTHROPIC_API_KEY yields one terminal EventError" $+    withUnsetEnv "ANTHROPIC_API_KEY" $ do+      let model =+            emptyModel+              & #modelId .~ "claude-test"+              & #api .~ AnthropicMessages+              & #provider .~ "anthropic"+      events <- Stream.toList (claudeMessagesStream model emptyContext emptyOptions)+      assertErrorContract events+      case last events of+        EventError TerminalPayload {errorInfo = Just be} ->+          be ^. #category @?= AuthError+        other -> assertFailure ("expected terminal EventError with AuthError, got: " <> show other)++cliMissingBinaryTest :: TestTree+cliMissingBinaryTest =+  testCase "claude CLI missing binary returns an error-shaped Response" $ do+    reg <- newProviderRegistry+    registerApiProviderWith+      reg+      (ClaudeCli.claudeCliProvider ClaudeCli.defaultClaudeCliConfig {ClaudeCli.executable = "/nonexistent/claude-binary"})+    let model =+          emptyModel+            & #modelId .~ ""+            & #api .~ AnthropicMessagesCli+            & #provider .~ "anthropic"+        ctx = emptyContext & #messages .~ Vector.singleton (user "ping")+    resp <- completeRequestWith reg model ctx emptyOptions+    case responseError resp of+      Just be -> be ^. #category @?= OtherError+      Nothing -> assertFailure "expected missing binary to be returned in-band"++withUnsetEnv :: String -> IO a -> IO a+withUnsetEnv name action =+  bracket+    (lookupEnv name)+    restore+    (const (unsetEnv name >> action))+  where+    restore = maybe (unsetEnv name) (setEnv name)++assertErrorContract :: [AssistantMessageEvent] -> Assertion+assertErrorContract events = do+  let terminals = filter isTerminal events+  length terminals @?= 1+  case terminals of+    [EventError TerminalPayload {errorInfo = Nothing}] ->+      assertFailure "terminal EventError omitted errorInfo"+    _ -> pure ()++assistantText :: Response -> Text.Text+assistantText resp =+  Text.concat+    [ t+    | AssistantText (TextContent t) <- Vector.toList (resp ^. #message ^. #content)+    ]

@@ -0,0 +1,126 @@+module ShapeSpec (tests) where++import Baikai+import Baikai.Models.Generated qualified as Models+import Baikai.Provider.Claude.Internal.Request (mapRequest)+import Baikai.Provider.Claude.Shape (streamRequestBody)+import Control.Lens ((&), (.~))+import Data.Aeson (Value (..), (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as AesonKey+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "ShapeSpec"+    [ verbatimToolSchemaTest,+      toolChoiceNoneTest,+      toolCacheControlTest,+      toolCacheControlCompatGateTest+    ]++verbatimToolSchemaTest :: TestTree+verbatimToolSchemaTest =+  testCase "tool input_schema is the caller's verbatim JSON Schema" $ do+    let schema =+          Aeson.object+            [ "type" .= ("object" :: Text.Text),+              "$defs"+                .= Aeson.object+                  [ "unit"+                      .= Aeson.object+                        [ "enum" .= (["c", "f"] :: [Text.Text])+                        ]+                  ],+              "additionalProperties" .= False+            ]+        ctx =+          emptyContext+            & #tools+              .~ Vector.singleton+                (emptyTool & #name .~ "weather" & #description .~ "Weather" & #parameters .~ schema)+    value <- shapedBody Models.anthropic_claude_haiku_4_5 ctx emptyOptions+    lookupPath ["tools", "0", "input_schema"] value @?= Just schema++toolChoiceNoneTest :: TestTree+toolChoiceNoneTest =+  testCase "ToolChoiceNone keeps tools and sends tool_choice none" $ do+    let ctx =+          emptyContext+            & #tools+              .~ Vector.singleton+                (emptyTool & #name .~ "lookup" & #description .~ "Lookup" & #parameters .~ objectSchema)+        opts = emptyOptions & #toolChoice .~ Just ToolChoiceNone+    value <- shapedBody Models.anthropic_claude_haiku_4_5 ctx opts+    assertBool "tools should remain present" (hasNonEmptyTools value)+    lookupPath ["tool_choice", "type"] value @?= Just (String "none")++toolCacheControlTest :: TestTree+toolCacheControlTest =+  testCase "cache marker lands on the last tool definition with ttl" $ do+    let ctx =+          emptyContext+            & #tools+              .~ Vector.fromList+                [ emptyTool & #name .~ "first" & #description .~ "First" & #parameters .~ objectSchema,+                  emptyTool & #name .~ "second" & #description .~ "Second" & #parameters .~ objectSchema+                ]+        opts = emptyOptions & #cacheRetention .~ Just CacheRetentionLong+    value <- shapedBody Models.anthropic_claude_haiku_4_5 ctx opts+    lookupPath ["tools", "0", "cache_control"] value @?= Nothing+    lookupPath ["tools", "1", "cache_control"] value+      @?= Just+        ( Aeson.object+            [ "type" .= ("ephemeral" :: Text.Text),+              "ttl" .= ("1h" :: Text.Text)+            ]+        )++toolCacheControlCompatGateTest :: TestTree+toolCacheControlCompatGateTest =+  testCase "supportsCacheControlOnTools gates tool cache markers" $ do+    let compat =+          defaultAnthropicMessagesCompat+            { supportsCacheControlOnTools = False+            }+        model =+          Models.anthropic_claude_haiku_4_5+            & #compat .~ CompatAnthropicMessages compat+        ctx =+          emptyContext+            & #tools+              .~ Vector.singleton+                (emptyTool & #name .~ "lookup" & #description .~ "Lookup" & #parameters .~ objectSchema)+        opts = emptyOptions & #cacheRetention .~ Just CacheRetentionShort+    value <- shapedBody model ctx opts+    lookupPath ["tools", "0", "cache_control"] value @?= Nothing++shapedBody :: Model -> Context -> Options -> IO Value+shapedBody model ctx opts = do+  req <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts)+  pure (streamRequestBody (anthropicMessagesCompatFor model) ctx opts req)++objectSchema :: Value+objectSchema = Aeson.object ["type" .= ("object" :: Text.Text)]++hasNonEmptyTools :: Value -> Bool+hasNonEmptyTools value =+  case lookupPath ["tools"] value of+    Just (Array xs) -> not (Vector.null xs)+    _ -> False++lookupPath :: [Text.Text] -> Value -> Maybe Value+lookupPath [] value = Just value+lookupPath (field : rest) (Object obj) =+  KeyMap.lookup (AesonKey.fromText field) obj >>= lookupPath rest+lookupPath (field : rest) (Array xs)+  | [(i, "")] <- reads (Text.unpack field),+    i >= 0,+    i < Vector.length xs =+      lookupPath rest (xs Vector.! i)+lookupPath _ _ = Nothing

@@ -0,0 +1,69 @@+module SseSpec (tests) where++import Baikai.Error (ErrorCategory (..), category, httpStatus, retryAfterSeconds)+import Baikai.Provider.Claude.Sse (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 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, (@?=))++tests :: TestTree+tests =+  testGroup+    "Baikai.Provider.Claude.Sse"+    [ testCase "non-2xx response preserves Retry-After and status" $ do+        eventsRef <- newIORef []+        resp <- mkResponse 429 [("Retry-After", "7")] ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"]+        sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev]))+        events <- readIORef eventsRef+        case events of+          [Left e] -> do+            category e @?= RateLimited+            retryAfterSeconds e @?= Just 7+            httpStatus e @?= Just 429+          other -> assertFailure ("expected one classified error, got: " <> show other),+      testCase "200 response decodes split SSE data frames in order" $ do+        eventsRef <- newIORef []+        resp <-+          mkResponse+            200+            []+            [ "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_1\",\"type\":\"message\",\"role\":\"assistant\",",+              "\"content\":[],\"model\":\"claude-test\",\"stop_reason\":null,\"stop_sequence\":null,",+              "\"usage\":{\"input_tokens\":3,\"output_tokens\":0}}}\r\n\r\n",+              "data: {\"type\":\"message_stop\"}\n\n"+            ]+        sseFromResponse resp (\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)+    ]++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 = []+      }

@@ -0,0 +1,378 @@+{-# LANGUAGE LambdaCase #-}++module ThinkingSpec (tests) where++import Baikai+import Baikai.Models.Generated+import Baikai.Provider.Claude.Api (Assembler, emptyAssembler, translate)+import Baikai.Provider.Claude.Internal.Request (mapRequest)+import Claude.V1.Messages qualified as Messages+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as BSL+import Data.Generics.Labels ()+import Data.IntMap.Strict qualified as IntMap+import Data.Text qualified as Text+import Data.Time.Clock (UTCTime)+import Data.Vector qualified as Vector+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "ThinkingSpec"+    [ testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests),+      explicitMaxTokensTest,+      handRolledUnclampedTest,+      tooSmallCapDropsThinkingTest,+      mergedOutputConfigTest,+      explicitCompatOverridesDefaultTest,+      streamFidelityTests+    ]++anthropicModels :: [(String, Model, AnthropicThinkingStyle)]+anthropicModels =+  [ ("claude-fable-5", anthropic_claude_fable_5, AnthropicThinkingAdaptive),+    ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget),+    ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget),+    ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive),+    ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive),+    ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive),+    ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget),+    ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingBudget)+  ]++thinkingLevels :: [(String, ThinkingLevel)]+thinkingLevels =+  [ ("minimal", ThinkingMinimal),+    ("low", ThinkingLow),+    ("medium", ThinkingMedium),+    ("high", ThinkingHigh)+  ]++neverExceedsCapTests :: [TestTree]+neverExceedsCapTests =+  [ testCase (name <> " " <> levelName <> " stays within catalog cap") $ do+      req <- requestFor model (emptyOptions & #thinking .~ Just level)+      Messages.max_tokens req <= model ^. #maxOutputTokens+        @?= True+  | (name, model, _) <- anthropicModels,+    (levelName, level) <- thinkingLevels+  ]++styleTests :: [TestTree]+styleTests =+  [ testCase (name <> " " <> levelName <> " selects expected thinking style") $ do+      req <- requestFor model (emptyOptions & #thinking .~ Just level)+      case style of+        AnthropicThinkingBudget -> do+          let expectedBudget = thinkingTokenBudget level+          requestThinking req+            @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = expectedBudget}+          assertBool+            "max_tokens leaves visible-output room beyond budget"+            (Messages.max_tokens req > expectedBudget)+        AnthropicThinkingAdaptive -> do+          requestThinking req @?= Just Messages.ThinkingAdaptive+          Messages.max_tokens req @?= model ^. #maxOutputTokens+          (Messages.output_config req >>= Messages.effort)+            @?= adaptiveEffort level+  | (name, model, style) <- anthropicModels,+    (levelName, level) <- thinkingLevels+  ]++explicitMaxTokensTest :: TestTree+explicitMaxTokensTest =+  testCase "explicit maxTokens participates as visible output plus budget, then clamps" $ do+    let opts =+          emptyOptions+            & #thinking .~ Just ThinkingHigh+            & #maxTokens .~ Just 60000+        budget = thinkingTokenBudget ThinkingHigh+    req <- requestFor anthropic_claude_haiku_4_5 opts+    requestThinking req+      @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = budget}+    Messages.max_tokens req @?= anthropic_claude_haiku_4_5 ^. #maxOutputTokens++handRolledUnclampedTest :: TestTree+handRolledUnclampedTest =+  testCase "hand-rolled model with unknown cap is not clamped" $ do+    let model =+          emptyModel+            & #modelId .~ "custom-claude"+            & #api .~ AnthropicMessages+            & #reasoning .~ True+            & #maxOutputTokens .~ 0+            & #compat .~ CompatAnthropicMessages defaultAnthropicMessagesCompat+        opts =+          emptyOptions+            & #thinking .~ Just ThinkingLow+            & #maxTokens .~ Just 100+        expected = 100 + thinkingTokenBudget ThinkingLow+    req <- requestFor model opts+    Messages.max_tokens req @?= expected++tooSmallCapDropsThinkingTest :: TestTree+tooSmallCapDropsThinkingTest =+  testCase "cap at or below the budget drops the thinking field" $ do+    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++mergedOutputConfigTest :: TestTree+mergedOutputConfigTest =+  testCase "adaptive effort merges with responseFormat output_config" $ do+    let schema = Aeson.object ["type" Aeson..= ("object" :: Text.Text)]+        opts =+          emptyOptions+            & #thinking .~ Just ThinkingMedium+            & #responseFormat+              .~ Just (JsonSchema {name = "answer", schema = schema, strict = True})+        expected = (Messages.jsonSchemaConfig schema) {Messages.effort = Just "medium"}+    req <- requestFor anthropic_claude_opus_4_6 opts+    requestThinking req @?= Just Messages.ThinkingAdaptive+    Messages.output_config req @?= Just expected++explicitCompatOverridesDefaultTest :: TestTree+explicitCompatOverridesDefaultTest =+  testCase "explicit CompatAnthropicMessages thinkingStyle overrides model generation default" $ do+    let compat =+          defaultAnthropicMessagesCompat+            { thinkingStyle = AnthropicThinkingAdaptive+            }+        model =+          anthropic_claude_haiku_4_5+            & #compat .~ CompatAnthropicMessages compat+        opts = emptyOptions & #thinking .~ Just ThinkingLow+    req <- requestFor model opts+    requestThinking req @?= Just Messages.ThinkingAdaptive+    (Messages.output_config req >>= Messages.effort) @?= Just "low"++requestFor :: Model -> Options -> IO Messages.CreateMessage+requestFor model opts = case mapRequest model emptyContext opts of+  Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)+  Right req -> pure req++requestThinking :: Messages.CreateMessage -> Maybe Messages.Thinking+requestThinking Messages.CreateMessage {Messages.thinking = t} = t++adaptiveEffort :: ThinkingLevel -> Maybe Text.Text+adaptiveEffort = \case+  ThinkingMinimal -> Just "low"+  ThinkingLow -> Just "low"+  ThinkingMedium -> Just "medium"+  ThinkingHigh -> Nothing++streamFidelityTests :: TestTree+streamFidelityTests =+  testGroup+    "stream fidelity and replay"+    [ testCase "thinking and redacted blocks close with full ThinkingContent" $ do+        let (events, _) = runClaudeEvents signedAndRedactedStream+            expectedSigned =+              ThinkingContent+                { thinking = "because therefore",+                  signature = Just "sig-final",+                  redacted = False+                }+            expectedRedacted =+              ThinkingContent+                { thinking = "ENCRYPTED==",+                  signature = Nothing,+                  redacted = True+                }+        thinkingEnds events+          @?= [expectedSigned, expectedRedacted]+        assistantContentFromTerminal events+          @?= Vector.fromList+            [ AssistantThinking expectedSigned,+              AssistantThinking expectedRedacted+            ],+      testCase "assembled thinking blocks replay signature and redacted payload verbatim" $ do+        let (events, _) = runClaudeEvents signedAndRedactedStream+            msg = terminalMessage events+            ctx =+              emptyContext+                & #messages+                  .~ Vector.fromList+                    [ msg,+                      user "continue"+                    ]+        req <- requestForContext anthropic_claude_haiku_4_5 ctx emptyOptions+        case Vector.toList (requestMessages req) of+          (assistantMsg : _) ->+            BSL.toStrict (Aeson.encode (messageContent assistantMsg))+              @?= BSL.toStrict+                ( Aeson.encode+                    ( Vector.fromList+                        [ Messages.Content_Thinking+                            { Messages.thinking = "because therefore",+                              Messages.signature = "sig-final"+                            },+                          Messages.Content_Redacted_Thinking+                            { Messages.data_ = "ENCRYPTED=="+                            }+                        ]+                    )+                )+          _ -> assertFailure "mapped request contained no assistant message",+      testCase "signature-less non-redacted thinking is omitted on replay" $ do+        let msg =+              AssistantMessage+                AssistantPayload+                  { content =+                      Vector.fromList+                        [ AssistantThinking+                            ThinkingContent+                              { thinking = "draft",+                                signature = Nothing,+                                redacted = False+                              },+                          AssistantText (TextContent "visible")+                        ],+                    usage = zeroUsage,+                    stopReason = Stop,+                    errorMessage = Nothing,+                    timestamp = Just testTime+                  }+            ctx = emptyContext & #messages .~ Vector.fromList [msg]+        req <- requestForContext anthropic_claude_haiku_4_5 ctx emptyOptions+        case Vector.toList (requestMessages req) of+          [assistantMsg] ->+            BSL.toStrict (Aeson.encode (messageContent assistantMsg))+              @?= BSL.toStrict+                ( Aeson.encode+                    ( Vector.singleton+                        Messages.Content_Text+                          { Messages.text = "visible",+                            Messages.cache_control = Nothing+                          }+                    )+                )+          _ -> assertFailure "expected exactly one mapped assistant message",+      testCase "unopened block deltas do not fabricate events or closed blocks" $ do+        let (events, ass) =+              runClaudeEvents+                [ Messages.Content_Block_Delta+                    { Messages.index = 7,+                      Messages.delta = Messages.Delta_Thinking_Delta {Messages.thinking = "ghost"}+                    },+                  Messages.Content_Block_Delta+                    { Messages.index = 8,+                      Messages.delta = Messages.Delta_Input_Json_Delta {Messages.partial_json = "{\"x\""}+                    },+                  Messages.Content_Block_Stop {Messages.index = 8}+                ]+        events @?= []+        IntMap.null (ass ^. #closed) @?= True+        IntMap.null (ass ^. #toolArgsBuf) @?= True+    ]++signedAndRedactedStream :: [Messages.MessageStreamEvent]+signedAndRedactedStream =+  [ messageStart,+    Messages.Content_Block_Start+      { Messages.index = 0,+        Messages.content_block = Messages.ContentBlock_Thinking {Messages.thinking = "", Messages.signature = ""}+      },+    Messages.Content_Block_Delta+      { Messages.index = 0,+        Messages.delta = Messages.Delta_Thinking_Delta {Messages.thinking = "because "}+      },+    Messages.Content_Block_Delta+      { Messages.index = 0,+        Messages.delta = Messages.Delta_Thinking_Delta {Messages.thinking = "therefore"}+      },+    Messages.Content_Block_Delta+      { Messages.index = 0,+        Messages.delta = Messages.Delta_Signature_Delta {Messages.signature = "sig-"}+      },+    Messages.Content_Block_Delta+      { Messages.index = 0,+        Messages.delta = Messages.Delta_Signature_Delta {Messages.signature = "final"}+      },+    Messages.Content_Block_Stop {Messages.index = 0},+    Messages.Content_Block_Start+      { Messages.index = 1,+        Messages.content_block = Messages.ContentBlock_Redacted_Thinking {Messages.data_ = "ENCRYPTED=="}+      },+    Messages.Content_Block_Stop {Messages.index = 1},+    Messages.Message_Delta+      { Messages.message_delta =+          Messages.MessageDelta+            { Messages.stop_reason = Just Messages.End_Turn,+              Messages.stop_sequence = Nothing+            },+        Messages.usage = Messages.StreamUsage {Messages.output_tokens = 12}+      },+    Messages.Message_Stop+  ]++messageStart :: Messages.MessageStreamEvent+messageStart =+  Messages.Message_Start+    { Messages.message =+        Messages.MessageResponse+          { Messages.id = "msg_test",+            Messages.type_ = "message",+            Messages.role = Messages.Assistant,+            Messages.content = Vector.empty,+            Messages.model = "claude-haiku-4-5",+            Messages.stop_reason = Nothing,+            Messages.stop_sequence = Nothing,+            Messages.usage =+              Messages.Usage+                { Messages.input_tokens = 10,+                  Messages.output_tokens = 0,+                  Messages.cache_creation_input_tokens = Nothing,+                  Messages.cache_read_input_tokens = Nothing,+                  Messages.server_tool_use = Nothing+                },+            Messages.container = Nothing+          }+    }++runClaudeEvents :: [Messages.MessageStreamEvent] -> ([AssistantMessageEvent], Assembler)+runClaudeEvents =+  foldl'+    ( \(events, ass) ev ->+        let (newEvents, ass') = translate (Right ev) ass testTime+         in (events <> newEvents, ass')+    )+    ([], emptyAssembler anthropic_claude_haiku_4_5 testTime)++thinkingEnds :: [AssistantMessageEvent] -> [ThinkingContent]+thinkingEnds events =+  [th | ThinkingEnd ThinkingEndPayload {content = th} <- events]++assistantContentFromTerminal :: [AssistantMessageEvent] -> Vector.Vector AssistantContent+assistantContentFromTerminal events =+  case terminalMessage events of+    AssistantMessage AssistantPayload {content = blocks} -> blocks+    _ -> Vector.empty++terminalMessage :: [AssistantMessageEvent] -> Message+terminalMessage events =+  case last events of+    EventDone TerminalPayload {message = msg} -> msg+    EventError TerminalPayload {message = msg} -> msg+    _ -> 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++requestMessages :: Messages.CreateMessage -> Vector.Vector Messages.Message+requestMessages Messages.CreateMessage {Messages.messages = msgs} = msgs++messageContent :: Messages.Message -> Vector.Vector Messages.Content+messageContent Messages.Message {Messages.content = blocks} = blocks++testTime :: UTCTime+testTime = read "2026-07-03 12:00:00 UTC"

@@ -0,0 +1,96 @@+module TransportSpec (tests) where++import Baikai+import Baikai.Provider.Claude.Transport qualified as Transport+import Control.Concurrent (threadDelay)+import Control.Exception (bracket, try)+import Control.Lens ((&), (.~), (^.))+import Data.CaseInsensitive qualified as CI+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Vector qualified as Vector+import Network.HTTP.Types.Header (RequestHeaders)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Baikai.Provider.Claude.Transport"+    [ clientEnvCacheTest,+      requestHeadersTest,+      sessionAffinityTest,+      timeoutTest,+      unknownHostKeyTest+    ]++clientEnvCacheTest :: TestTree+clientEnvCacheTest =+  testCase "cached ClientEnv is allocated once for a base URL" $ do+    let url = "https://cache-anthropic.test"+    before <- Transport.cachedClientEnvCount+    _ <- Transport.getClientEnvCached url+    afterFirst <- Transport.cachedClientEnvCount+    _ <- Transport.getClientEnvCached url+    afterSecond <- Transport.cachedClientEnvCount+    afterFirst @?= before + 1+    afterSecond @?= afterFirst++requestHeadersTest :: TestTree+requestHeadersTest =+  testCase "model and option headers reach the wire, options winning case-insensitively" $ do+    let model =+          emptyModel+            & #headers .~ Map.fromList [("X-Trace", "model"), ("x-api-key", "model-key")]+        opts =+          emptyOptions+            & #headers .~ Map.fromList [("x-trace", "option"), ("X-API-Key", "option-key")]+        headers = Transport.requestHeaders "secret" (Just "2023-06-01") defaultAnthropicMessagesCompat emptyContext model opts+    header "X-Trace" headers @?= Just "option"+    header "x-api-key" headers @?= Just "option-key"+    header "anthropic-version" headers @?= Just "2023-06-01"++sessionAffinityTest :: TestTree+sessionAffinityTest =+  testCase "sendSessionAffinityHeaders adds a stable session header" $ do+    let compat = defaultAnthropicMessagesCompat {sendSessionAffinityHeaders = True}+        ctx =+          emptyContext+            & #systemPrompt .~ Just "system"+            & #messages .~ Vector.singleton (user "first")+        headers = Transport.requestHeaders "secret" Nothing compat ctx emptyModel emptyOptions+        affinity = Transport.sessionAffinityValue ctx+    Text.length affinity @?= 64+    header "x-session-affinity" headers @?= Just affinity++timeoutTest :: TestTree+timeoutTest =+  testCase "runWithTimeout classifies an elapsed whole-call timeout as transient" $ do+    result <- Transport.runWithTimeout (Just 1) (threadDelay 100000)+    case result of+      Just be -> do+        be ^. #category @?= TransientError+        "timeoutMs=1" `Text.isInfixOf` (be ^. #message) @?= True+      Nothing -> assertFailure "expected timeout error"++unknownHostKeyTest :: TestTree+unknownHostKeyTest =+  testCase "unknown hosts do not fall back to ANTHROPIC_API_KEY" $+    withEnv "ANTHROPIC_API_KEY" "anthropic-secret" $ do+      result <- try (Transport.resolveKey "https://unknown.example" emptyOptions) :: IO (Either BaikaiError Text.Text)+      case result of+        Left be -> be ^. #category @?= AuthError+        Right _ -> assertFailure "expected AuthError for unknown host"++header :: Text.Text -> RequestHeaders -> Maybe Text.Text+header name headers =+  Text.decodeUtf8 <$> lookup (CI.mk (Text.encodeUtf8 name)) headers++withEnv :: String -> String -> IO a -> IO a+withEnv name value =+  bracket+    (lookupEnv name <* setEnv name value)+    (maybe (unsetEnv name) (setEnv name))+    . const