baikai-claude (empty) → 0.1.0.0
raw patch · 6 files changed
+1274/−0 lines, 6 filesdep +aesondep +baikaidep +baikai-claude
Dependencies added: aeson, baikai, baikai-claude, base, base64-bytestring, bytestring, claude, containers, cradle, generic-lens, http-client, http-client-tls, lens, servant-client, streamly, streamly-core, tasty, tasty-hunit, text, time, vector
Files
- LICENSE +30/−0
- baikai-claude.cabal +78/−0
- src/Baikai/Provider/Claude/Api.hs +764/−0
- src/Baikai/Provider/Claude/Cli.hs +208/−0
- src/Baikai/Provider/Claude/Interactive.hs +94/−0
- test/Main.hs +100/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2026 Nadeem Bitar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nadeem Bitar nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ baikai-claude.cabal view
@@ -0,0 +1,78 @@+cabal-version: 3.4+name: baikai-claude+version: 0.1.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+ claude -p CLI.++category: AI+license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: nadeem@gmail.com+copyright: (c) 2026 Nadeem Bitar+build-type: Simple++common common-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wredundant-constraints+ -fhide-source-paths -Wmissing-export-lists -Wpartial-fields+ -Wmissing-deriving-strategies++ default-language: GHC2024+ default-extensions:+ DeriveAnyClass+ DuplicateRecordFields+ OverloadedLabels+ OverloadedStrings++library+ import: common-options+ hs-source-dirs: src+ exposed-modules:+ Baikai.Provider.Claude.Api+ Baikai.Provider.Claude.Cli+ Baikai.Provider.Claude.Interactive++ build-depends:+ , aeson+ , baikai ^>=0.1.0+ , base >=4.20 && <5+ , base64-bytestring+ , bytestring+ , claude+ , containers+ , cradle+ , generic-lens+ , http-client+ , http-client-tls+ , lens ^>=5.3+ , servant-client+ , streamly >=0.11 && <0.13+ , streamly-core >=0.3 && <0.5+ , text ^>=2.1+ , time+ , vector++test-suite baikai-claude-test+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs++ -- cradle (used by Baikai.Provider.Claude.Interactive) requires the threaded RTS.+ ghc-options: -threaded -with-rtsopts=-N+ build-depends:+ , baikai ^>=0.1.0+ , baikai-claude+ , base >=4.20 && <5+ , bytestring+ , generic-lens+ , lens ^>=5.3+ , streamly-core >=0.3 && <0.5+ , tasty+ , tasty-hunit+ , text ^>=2.1+ , vector
+ src/Baikai/Provider/Claude/Api.hs view
@@ -0,0 +1,764 @@+{-# LANGUAGE LambdaCase #-}++-- | Provider wrapping the @claude@ package's Messages API.+--+-- Call 'register' once (typically from @main@) to install the+-- 'Baikai.Api.AnthropicMessages' handler into the baikai provider+-- registry. After registration, any 'Baikai.Model.Model' whose+-- 'Baikai.Api.api' tag is 'AnthropicMessages' dispatches through+-- this handler.+--+-- The handler resolves 'Baikai.Options.apiKey' when present, falling+-- back to the @ANTHROPIC_API_KEY@ env var via+-- 'Baikai.Auth.resolveApiKey'.+--+-- 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.+module Baikai.Provider.Claude.Api+ ( register,+ registerWithRegistry,+ claudeMessagesStream,+ )+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.Pricing qualified as Pricing+import Baikai.Message qualified as Msg+import Baikai.Model (Model, anthropicMessagesCompatFor)+import Baikai.Options (Options (..))+import Baikai.Provider.Registry+ ( ApiProvider (..),+ ProviderRegistry,+ globalProviderRegistry,+ registerApiProviderWith,+ )+import Baikai.StopReason qualified as Stop+import Baikai.Stream (streamingComplete)+import Baikai.Stream.Event+ ( AssistantMessageEvent (..),+ BlockEndPayload (..),+ DeltaPayload (..),+ IndexPayload (..),+ StartPayload (..),+ TerminalPayload (..),+ ToolCallEndPayload (..),+ )+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, displayException, try)+import Control.Lens ((%~), (&), (.~), (^.))+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)+import Data.IntMap.Strict qualified as IntMap+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++-- | Install the Anthropic Messages handler into the registry.+-- Calling 'register' twice keeps only the second handler — the+-- registry's insert-overwrites semantic.+register :: IO ()+register = registerWithRegistry globalProviderRegistry++-- | Install the Anthropic Messages handler into an explicit registry.+registerWithRegistry :: ProviderRegistry -> IO ()+registerWithRegistry reg =+ registerApiProviderWith+ reg+ ApiProvider+ { apiTag = AnthropicMessages,+ stream = claudeMessagesStream,+ complete = streamingComplete claudeMessagesStream+ }++-- | 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+-- with exactly one 'EventDone' or 'EventError'.+--+-- Producer-side exceptions (HTTP failure, decode failure inside the+-- SDK, etc.) are caught with 'try' and re-encoded into an+-- 'EventError' carrying whatever content was already assembled —+-- the masterplan's "partial output is always recoverable" promise.+claudeMessagesStream ::+ Model -> Context -> Options -> Stream IO AssistantMessageEvent+claudeMessagesStream m ctx opts =+ Stream.concatEffect $ do+ setup <- prepareCall m ctx opts+ case setup of+ Left err -> pure (Stream.fromEffect (immediateError err))+ Right call -> do+ ch <- newChan :: IO (Chan (Maybe Messages.MessageStreamEvent))+ tref <- newIORef False+ _ <- forkIO (worker call ch tref)+ startTime <- getCurrentTime+ let initialState =+ ProducerState+ { chan = ch,+ pending = [],+ assembler = emptyAssembler m startTime,+ finished = False,+ terminalRef = tref+ }+ pure (Stream.unfoldrM step initialState)++-- | Per-call prepared values: the typed SDK request, plus the+-- methods record to invoke the streaming endpoint.+data ClaudeCall = ClaudeCall+ { methods :: !Claude.Methods,+ request :: !Messages.CreateMessage+ }+ deriving stock (Generic)++prepareCall ::+ Model -> Context -> Options -> IO (Either Text ClaudeCall)+prepareCall m ctx opts = do+ case mapRequest m ctx opts of+ Left e -> pure (Left 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")++-- | Worker body: drive the SDK's typed callback, forwarding events+-- onto the channel. Any exception is converted into a synthetic+-- @Error@ raw event so the consumer side can translate it through+-- the normal channel. After the SDK call returns (success or+-- handled failure) we close the channel with 'Nothing'.+worker ::+ ClaudeCall ->+ Chan (Maybe Messages.MessageStreamEvent) ->+ IORef Bool ->+ IO ()+worker call ch _terminalRef = do+ let Claude.Methods {Claude.createMessageStreamTyped = stream'} = call ^. #methods+ r <-+ try @SomeException $+ stream' (call ^. #request) $ \case+ Left errText -> writeChan ch (Just (errorEvent errText))+ Right ev -> writeChan ch (Just ev)+ case r of+ Right () -> pure ()+ Left e -> writeChan ch (Just (errorEvent (Text.pack (displayException 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)),+ pending :: ![AssistantMessageEvent],+ assembler :: !Assembler,+ finished :: !Bool,+ terminalRef :: !(IORef Bool)+ }+ deriving stock (Generic)++step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState))+step s+ | (e : rest) <- s ^. #pending = do+ writeTerminal s e+ pure+ ( Just+ ( e,+ s+ & #pending .~ rest+ & #finished .~ (s ^. #finished || terminal e)+ )+ )+ | s ^. #finished = pure Nothing+ | otherwise = do+ mRaw <- readChan (s ^. #chan)+ case mRaw of+ Nothing -> do+ alreadyTerminal <- readIORef (s ^. #terminalRef)+ if alreadyTerminal+ then pure Nothing+ else do+ now <- getCurrentTime+ let (ev, ass') = unexpectedEoS now (s ^. #assembler)+ writeTerminal s ev+ pure+ ( Just+ ( ev,+ s & #assembler .~ ass' & #finished .~ True+ )+ )+ Just raw -> do+ now <- getCurrentTime+ let (events, ass') = translate raw (s ^. #assembler) now+ case events of+ [] -> step (s & #assembler .~ ass')+ (e : rest) -> do+ writeTerminal s e+ pure+ ( Just+ ( e,+ s+ & #pending .~ rest+ & #assembler .~ ass'+ & #finished .~ (s ^. #finished || terminal e)+ )+ )++writeTerminal :: ProducerState -> AssistantMessageEvent -> IO ()+writeTerminal s ev+ | terminal ev = writeIORef (s ^. #terminalRef) True+ | otherwise = pure ()++terminal :: AssistantMessageEvent -> Bool+terminal = \case+ EventDone {} -> True+ EventError {} -> True+ _ -> False++-- | The recovery path: channel closed before any terminal event.+unexpectedEoS :: UTCTime -> Assembler -> (AssistantMessageEvent, Assembler)+unexpectedEoS now ass =+ let msg =+ finalMessageOnError+ ass+ now+ "claude stream ended without message_stop"+ in (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}, ass)++-- | Translation state across one streaming call.+data Assembler = Assembler+ { model :: !Model,+ start :: !UTCTime,+ responseId :: !(Maybe Text),+ closed :: !(IntMap Content.AssistantContent),+ textBuf :: !(IntMap Text),+ thinkBuf :: !(IntMap Text),+ thinkSig :: !(IntMap Text),+ toolArgsBuf :: !(IntMap Text),+ toolMeta :: !(IntMap (Text, Text)),+ usage :: !Usage.Usage,+ stopReason :: !Stop.StopReason+ }+ deriving stock (Generic)++emptyAssembler :: Model -> UTCTime -> Assembler+emptyAssembler m s =+ Assembler+ { model = m,+ start = s,+ responseId = Nothing,+ closed = IntMap.empty,+ textBuf = IntMap.empty,+ thinkBuf = IntMap.empty,+ thinkSig = IntMap.empty,+ toolArgsBuf = IntMap.empty,+ toolMeta = IntMap.empty,+ usage = Usage._Usage,+ stopReason = Stop.Stop+ }++translate ::+ Messages.MessageStreamEvent ->+ Assembler ->+ UTCTime ->+ ([AssistantMessageEvent], Assembler)+translate 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')+ 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} ->+ handleBlockDelta (fromIntegral idx) d ass+ Messages.Content_Block_Stop {Messages.index = idx} ->+ handleBlockStop (fromIntegral idx) ass+ Messages.Message_Delta {Messages.message_delta = md, Messages.usage = su} ->+ let stopR = mapStopReason (md ^. #stop_reason)+ u = ass ^. #usage+ outputTokensFinal = fromMaybe (u ^. #outputTokens) (Just (su ^. #output_tokens))+ u' =+ u+ & #outputTokens .~ outputTokensFinal+ & #totalTokens+ .~ ((u ^. #inputTokens) + outputTokensFinal + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens))+ in ([], ass & #stopReason .~ stopR & #usage .~ u')+ Messages.Message_Stop ->+ let msg = finalMessage ass now+ in ([EventDone TerminalPayload {reason = ass ^. #stopReason, message = msg}], ass)+ Messages.Error {Messages.error = errVal} ->+ let errText = renderAnthropicError errVal+ msg = finalMessageOnError ass now errText+ in ([EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}], ass)++handleBlockStart ::+ Int ->+ Messages.ContentBlock ->+ Assembler ->+ ([AssistantMessageEvent], Assembler)+handleBlockStart i block ass = case block of+ Messages.ContentBlock_Text {} ->+ ( [TextStart IndexPayload {contentIndex = i}],+ ass & #textBuf %~ IntMap.insert i Text.empty+ )+ Messages.ContentBlock_Thinking {} ->+ ( [ThinkingStart IndexPayload {contentIndex = i}],+ ass & #thinkBuf %~ IntMap.insert i Text.empty+ )+ Messages.ContentBlock_Redacted_Thinking {} ->+ ( [ThinkingStart IndexPayload {contentIndex = i}],+ ass & #thinkBuf %~ IntMap.insert i Text.empty+ )+ Messages.ContentBlock_Tool_Use {Messages.id = tid, Messages.name = tn} ->+ ( [ToolCallStart IndexPayload {contentIndex = i}],+ ass+ & #toolArgsBuf %~ IntMap.insert i Text.empty+ & #toolMeta %~ IntMap.insert i (tid, tn)+ )+ _ ->+ -- Server-tool, code-execution-tool, unknown — pass-through with no events.+ ([], ass)++handleBlockDelta ::+ Int ->+ Messages.ContentBlockDelta ->+ Assembler ->+ ([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+ )+ Messages.Delta_Thinking_Delta {Messages.thinking = t} ->+ ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}],+ ass & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i t+ )+ 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+ )+ 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+ )++handleBlockStop ::+ Int -> Assembler -> ([AssistantMessageEvent], Assembler)+handleBlockStop i ass+ | Just body <- IntMap.lookup i (ass ^. #textBuf) =+ let block = Content.AssistantText (Content.TextContent body)+ in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}],+ ass+ & #closed %~ IntMap.insert i block+ & #textBuf %~ 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}],+ 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))+ decoded :: Value+ decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 argsText) of+ Right v -> v+ Left _ ->+ -- Anthropic sometimes opens a tool_use block with an+ -- empty input that never streams any delta. Fall back+ -- to an empty object so the resulting ToolCall is+ -- well-formed.+ Aeson.Object mempty+ tc =+ Content.ToolCall+ { Content.id_ = tid,+ Content.name = tn,+ Content.arguments = decoded+ }+ block = Content.AssistantToolCall tc+ in ( [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}],+ ass+ & #closed %~ IntMap.insert i block+ & #toolArgsBuf %~ IntMap.delete i+ & #toolMeta %~ IntMap.delete i+ )+ | otherwise = ([], ass)++-- | The 'EventStart' message skeleton (empty content; usage/etc.+-- carried for downstream consumers that want metadata up front).+skeletonMessage :: Assembler -> UTCTime -> Msg.Message+skeletonMessage ass _now =+ Msg.AssistantMessage+ Msg.AssistantPayload+ { Msg.content = Vector.empty,+ Msg.usage = ass ^. #usage,+ Msg.stopReason = Stop.Stop,+ Msg.errorMessage = Nothing,+ Msg.timestamp = ass ^. #start+ }++finalMessage :: Assembler -> UTCTime -> Msg.Message+finalMessage ass now =+ let blocks = blocksInOrder ass+ m = ass ^. #model+ usageBare = ass ^. #usage+ computed = Pricing.computeCost m usageBare+ usage' = usageBare & #cost .~ computed+ in Msg.AssistantMessage+ Msg.AssistantPayload+ { Msg.content = blocks,+ Msg.usage = usage',+ Msg.stopReason = ass ^. #stopReason,+ Msg.errorMessage = Nothing,+ Msg.timestamp = now+ }++finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message+finalMessageOnError ass now reason =+ let blocks = blocksInOrder ass+ m = ass ^. #model+ usageBare = ass ^. #usage+ computed = Pricing.computeCost m usageBare+ usage' = usageBare & #cost .~ computed+ in Msg.AssistantMessage+ Msg.AssistantPayload+ { Msg.content = blocks,+ Msg.usage = usage',+ Msg.stopReason = Stop.ErrorReason,+ Msg.errorMessage = Just reason,+ Msg.timestamp = now+ }++blocksInOrder :: Assembler -> Vector Content.AssistantContent+blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed))++-- | 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+ now <- getCurrentTime+ let msg =+ Msg.AssistantMessage+ Msg.AssistantPayload+ { Msg.content = Vector.empty,+ Msg.usage = Usage._Usage,+ Msg.stopReason = Stop.ErrorReason,+ Msg.errorMessage = Just errText,+ Msg.timestamp = now+ }+ pure (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg})++renderAnthropicError :: Value -> Text+renderAnthropicError v = case v of+ Aeson.String t -> t+ _ -> Text.decodeUtf8 (BSL.toStrict (Aeson.encode v))++-- | Map the Anthropic streaming 'Message_Start.message.usage' value+-- into baikai's 'Usage' shape. Cache-related counters are populated+-- where present; cost is left at zero (the terminal event+-- recomputes it).+anthroUsageToBaikai :: Messages.Usage -> Usage.Usage+anthroUsageToBaikai u =+ let i = u ^. #input_tokens+ o = u ^. #output_tokens+ cr = fromMaybe 0 (u ^. #cache_read_input_tokens)+ cw = fromMaybe 0 (u ^. #cache_creation_input_tokens)+ in Usage.Usage+ { Usage.inputTokens = i,+ Usage.outputTokens = o,+ Usage.cacheReadTokens = cr,+ 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+ 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+ }++-- | 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+ }++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+ Just Messages.End_Turn -> Stop.Stop+ Just Messages.Max_Tokens -> Stop.Length+ Just Messages.Stop_Sequence -> Stop.Stop+ Just Messages.Tool_Use -> Stop.ToolUse+ Just Messages.Refusal -> Stop.ErrorReason+ Just Messages.Model_Context_Window_Exceeded -> Stop.Length+ Nothing -> Stop.Stop
+ src/Baikai/Provider/Claude/Cli.hs view
@@ -0,0 +1,208 @@+-- | Provider that drives the @claude -p@ non-interactive CLI as a+-- subprocess.+--+-- Call 'register' once (typically from @main@) to install the+-- 'Baikai.Api.AnthropicMessagesCli' handler with default config.+-- For non-default executable paths or extra args, use 'registerWith'+-- and supply a custom 'ClaudeCliConfig'.+--+-- The CLI provider always returns a 'Response' whose embedded+-- assistant message carries zero token counts (and therefore zero+-- cost): the @claude@ CLI runs under a flat subscription, so+-- per-token billing does not apply. CLI providers do not participate+-- in tool calling — the masterplan's Decision Log records the+-- reasoning.+module Baikai.Provider.Claude.Cli+ ( ClaudeCliConfig (..),+ defaultClaudeCliConfig,+ register,+ registerWith,+ registerWithRegistry,+ registerWithRegistryAndConfig,+ )+where++import Baikai.Api (Api (..))+import Baikai.Content (AssistantContent (..), TextContent (..))+import Baikai.Context (Context (..))+import Baikai.Error (BaikaiError (..))+import Baikai.Message (AssistantPayload (..))+import Baikai.Model (Model)+import Baikai.Options (Options)+import Baikai.Provider.Cli.Internal qualified as Internal+import Baikai.Provider.Registry+ ( ApiProvider (..),+ ProviderRegistry,+ globalProviderRegistry,+ registerApiProviderWith,+ )+import Baikai.Response qualified as Resp+import Baikai.StopReason (StopReason (..))+import Baikai.Stream (liftCompleteToStream)+import Baikai.Usage (_Usage)+import Control.Exception (throwIO)+import Control.Lens ((^.))+import Cradle+ ( ExitCode (..),+ StderrRaw (..),+ StdoutRaw (..),+ addArgs,+ cmd,+ run,+ setNoStdin,+ setWorkingDir,+ )+import Data.Aeson (FromJSON, Value (..), eitherDecodeStrict)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither, parseJSON)+import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics (Generic)++-- | Configuration for the @claude -p@ subprocess.+data ClaudeCliConfig = ClaudeCliConfig+ { executable :: !FilePath,+ extraArgs :: !(Vector Text),+ workingDir :: !(Maybe FilePath)+ }+ deriving stock (Eq, Show, Generic)++defaultClaudeCliConfig :: ClaudeCliConfig+defaultClaudeCliConfig =+ ClaudeCliConfig+ { executable = "claude",+ extraArgs = mempty,+ workingDir = Nothing+ }++-- | Install the CLI handler with 'defaultClaudeCliConfig'.+register :: IO ()+register = registerWith defaultClaudeCliConfig++-- | Install the CLI handler with a caller-supplied config.+--+-- The CLI binary runs in batch mode; there is no intra-response+-- streaming on the wire. The 'stream' field therefore wraps the+-- batch 'runClaudeCli' through 'liftCompleteToStream', producing a+-- synthetic one-shot event stream+-- (@EventStart, TextStart 0, TextDelta 0 body, TextEnd 0, EventDone@)+-- the moment the subprocess returns. 'complete' is left as the+-- direct batch path so it preserves 'Response.responseId' and the+-- measured 'Response.latencyMs' (going through a+-- 'streamingComplete' round trip would lose the former and recompute+-- the latter from synthetic events). EP-3's Decision Log explains+-- the deviation from the plan's "complete = streamingComplete .+-- stream" default.+registerWith :: ClaudeCliConfig -> IO ()+registerWith = registerWithRegistryAndConfig globalProviderRegistry++-- | Install the CLI handler with 'defaultClaudeCliConfig' into an explicit+-- registry.+registerWithRegistry :: ProviderRegistry -> IO ()+registerWithRegistry reg = registerWithRegistryAndConfig reg defaultClaudeCliConfig++-- | Install the CLI handler with a caller-supplied config into an explicit+-- registry.+registerWithRegistryAndConfig :: ProviderRegistry -> ClaudeCliConfig -> IO ()+registerWithRegistryAndConfig reg cfg =+ registerApiProviderWith+ reg+ ApiProvider+ { apiTag = AnthropicMessagesCli,+ stream = liftCompleteToStream (runClaudeCli cfg),+ complete = runClaudeCli cfg+ }++-- | The shape of @claude -p --output-format json@ stdout.+data ClaudeCliResult = ClaudeCliResult+ { result :: !Text,+ is_error :: !Bool,+ session_id :: !(Maybe Text)+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON)++systemPromptArgs :: Context -> [String]+systemPromptArgs ctx = case ctx ^. #systemPrompt of+ Nothing -> []+ Just sp -> ["--system-prompt", Text.unpack sp]++modelArgs :: Model -> [String]+modelArgs m = case Text.strip (m ^. #modelId) of+ "" -> []+ mid -> ["--model", Text.unpack mid]++decodeResult :: ByteString -> IO ClaudeCliResult+decodeResult bs = case eitherDecodeStrict bs of+ Left err -> throwIO (DecodeError (Text.pack err))+ Right (Aeson.Array events) -> case findResultEvent events of+ Nothing -> throwIO (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+ 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")++findResultEvent :: Vector Value -> Maybe Value+findResultEvent = Vector.find isResult+ where+ isResult (Aeson.Object o) = case KeyMap.lookup "type" o of+ Just (Aeson.String "result") -> True+ _ -> False+ isResult _ = False++runClaudeCli :: ClaudeCliConfig -> Model -> Context -> Options -> IO Resp.Response+runClaudeCli cfg m ctx _opts = do+ let 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]+ start <- getCurrentTime+ (exitCode, StdoutRaw out, StderrRaw err) <-+ run $+ cmd (cfg ^. #executable)+ & 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))++mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response+mkResponse m start end body =+ Resp.Response+ { Resp.message =+ AssistantPayload+ { content = Vector.singleton (AssistantText (TextContent body)),+ usage = _Usage,+ stopReason = Stop,+ errorMessage = Nothing,+ timestamp = end+ },+ Resp.model = m,+ Resp.api = AnthropicMessagesCli,+ Resp.provider = m ^. #provider,+ Resp.responseId = Nothing,+ Resp.latencyMs = millisBetween start end+ }++millisBetween :: UTCTime -> UTCTime -> Integer+millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double))
+ src/Baikai/Provider/Claude/Interactive.hs view
@@ -0,0 +1,94 @@+-- | Launch real interactive Claude Code sessions from Baikai's+-- provider-neutral interactive request type.+--+-- This module is intentionally separate from+-- "Baikai.Provider.Claude.Cli": that module drives @claude -p@ as a+-- batch completion provider, while this module starts the interactive+-- terminal UI and returns only after the CLI exits.+module Baikai.Provider.Claude.Interactive+ ( ClaudeInteractiveConfig (..),+ defaultClaudeInteractiveConfig,+ claudeInteractiveCommand,+ launchClaudeInteractive,+ )+where++import Baikai.Interactive+ ( InteractiveLaunchRequest (..),+ InteractiveLaunchResult,+ InteractiveProvider (..),+ InteractiveSafety (..),+ _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)+ }+ deriving stock (Eq, Show, Generic)++defaultClaudeInteractiveConfig :: ClaudeInteractiveConfig+defaultClaudeInteractiveConfig =+ ClaudeInteractiveConfig+ { executable = "claude",+ extraArgs = mempty+ }++-- | Render the executable and arguments for an interactive Claude+-- Code launch. The final positional argument is the initial user+-- prompt.+claudeInteractiveCommand ::+ ClaudeInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String])+claudeInteractiveCommand cfg req =+ ( cfg ^. #executable,+ modelArgs req+ <> systemPromptArgs req+ <> extraDirArgs req+ <> safetyArgs req+ <> fmap Text.unpack (Vector.toList (cfg ^. #extraArgs))+ <> fmap Text.unpack (req ^. #extraArgs)+ <> [Text.unpack (req ^. #userPrompt)]+ )++-- | Launch Claude Code with inherited stdin, stdout, and stderr so+-- the local CLI owns the interactive terminal experience.+launchClaudeInteractive ::+ ClaudeInteractiveConfig -> InteractiveLaunchRequest -> IO InteractiveLaunchResult+launchClaudeInteractive cfg req = do+ let (exe, args) = claudeInteractiveCommand cfg req+ code <-+ run $+ cmd exe+ & addArgs args+ & maybe id setWorkingDir (req ^. #workingDir)+ pure (_InteractiveLaunchResult InteractiveClaude code)++modelArgs :: InteractiveLaunchRequest -> [String]+modelArgs req = case Text.strip <$> req ^. #model of+ Nothing -> []+ Just "" -> []+ Just mid -> ["--model", Text.unpack mid]++systemPromptArgs :: InteractiveLaunchRequest -> [String]+systemPromptArgs req = case Text.strip <$> req ^. #systemPrompt of+ Nothing -> []+ Just "" -> []+ Just prompt -> ["--system-prompt", Text.unpack prompt]++extraDirArgs :: InteractiveLaunchRequest -> [String]+extraDirArgs req =+ concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs)++safetyArgs :: InteractiveLaunchRequest -> [String]+safetyArgs req = case req ^. #safety of+ ClaudeAllowedTools [] -> []+ ClaudeAllowedTools tools ->+ ["--allowedTools", Text.unpack (Text.intercalate "," tools)]+ DefaultSafety -> []+ CodexSandbox _ _ -> []
+ test/Main.hs view
@@ -0,0 +1,100 @@+module Main (main) where++import Baikai+import Baikai.Provider.Claude.Api+import Baikai.Provider.Claude.Interactive+import Control.Lens ((&), (.~), (^.))+import Data.ByteString.Char8 qualified as BS8+import Data.Generics.Labels ()+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Streamly.Data.Stream qualified as Stream+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++main :: IO ()+main =+ defaultMain $+ testGroup+ "Baikai.Provider.Claude.Interactive"+ [ commandRenderingTest,+ compatDetectionTest,+ rejectsImageToolResultsTest+ ]++commandRenderingTest :: TestTree+commandRenderingTest =+ testCase "renders model, prompt, directories, allowed tools, and extra args" $ do+ let cfg =+ defaultClaudeInteractiveConfig+ { executable = "/bin/claude",+ extraArgs = Vector.fromList ["--debug"]+ }+ req =+ (_InteractiveLaunchRequest "inspect the repo")+ & #systemPrompt .~ Just "Be terse."+ & #model .~ Just "sonnet"+ & #workingDir .~ Just "/work/project"+ & #extraDirs .~ ["/work/shared", "/work/docs"]+ & #safety .~ ClaudeAllowedTools ["Read", "Bash(git status)"]+ & #extraArgs .~ ["--permission-mode", "plan"]+ claudeInteractiveCommand cfg req+ @?= ( "/bin/claude",+ [ "--model",+ "sonnet",+ "--system-prompt",+ "Be terse.",+ "--add-dir",+ "/work/shared",+ "--add-dir",+ "/work/docs",+ "--allowedTools",+ "Read,Bash(git status)",+ "--debug",+ "--permission-mode",+ "plan",+ "inspect the repo"+ ]+ )++compatDetectionTest :: TestTree+compatDetectionTest =+ testCase "Anthropic-compatible hosts auto-detect request-shaping compat flags" $ do+ let model =+ _Model+ & #api .~ AnthropicMessages+ & #baseUrl .~ "https://api.fireworks.ai/inference/v1"+ compat = anthropicMessagesCompatFor model+ compat ^. #supportsCacheControlOnTools @?= False+ compat ^. #sendSessionAffinityHeaders @?= True+ compat ^. #supportsLongCacheRetention @?= False++rejectsImageToolResultsTest :: TestTree+rejectsImageToolResultsTest =+ testCase "Claude API mapping rejects image tool-result blocks instead of dropping them" $ do+ let model =+ _Model+ & #modelId .~ "claude-test"+ & #api .~ AnthropicMessages+ & #provider .~ "anthropic"+ image = ImageContent {imageData = BS8.pack "png-bytes", mimeType = "image/png"}+ ctx =+ _Context+ & #messages+ .~ Vector.singleton+ ( ToolResultMessage+ ToolResultPayload+ { toolCallId = "call_1",+ toolName = "render",+ content = Vector.singleton (ToolResultImage image),+ isError = False,+ timestamp = read "2026-06-05 00:00:00 UTC"+ }+ )+ events <- Stream.toList (claudeMessagesStream model ctx _Options)+ 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)