diff --git a/baikai-claude.cabal b/baikai-claude.cabal --- a/baikai-claude.cabal +++ b/baikai-claude.cabal @@ -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 diff --git a/src/Baikai/Provider/Claude/Api.hs b/src/Baikai/Provider/Claude/Api.hs --- a/src/Baikai/Provider/Claude/Api.hs +++ b/src/Baikai/Provider/Claude/Api.hs @@ -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 diff --git a/src/Baikai/Provider/Claude/Cli.hs b/src/Baikai/Provider/Claude/Cli.hs --- a/src/Baikai/Provider/Claude/Cli.hs +++ b/src/Baikai/Provider/Claude/Cli.hs @@ -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) diff --git a/src/Baikai/Provider/Claude/ErrorClass.hs b/src/Baikai/Provider/Claude/ErrorClass.hs deleted file mode 100644 --- a/src/Baikai/Provider/Claude/ErrorClass.hs +++ /dev/null @@ -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 diff --git a/src/Baikai/Provider/Claude/Interactive.hs b/src/Baikai/Provider/Claude/Interactive.hs --- a/src/Baikai/Provider/Claude/Interactive.hs +++ b/src/Baikai/Provider/Claude/Interactive.hs @@ -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] diff --git a/src/Baikai/Provider/Claude/Internal/ErrorClass.hs b/src/Baikai/Provider/Claude/Internal/ErrorClass.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Internal/ErrorClass.hs @@ -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 diff --git a/src/Baikai/Provider/Claude/Internal/Request.hs b/src/Baikai/Provider/Claude/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Internal/Request.hs @@ -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 diff --git a/src/Baikai/Provider/Claude/Shape.hs b/src/Baikai/Provider/Claude/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Shape.hs @@ -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 diff --git a/src/Baikai/Provider/Claude/Sse.hs b/src/Baikai/Provider/Claude/Sse.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Sse.hs @@ -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 diff --git a/src/Baikai/Provider/Claude/Transport.hs b/src/Baikai/Provider/Claude/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Transport.hs @@ -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) diff --git a/test/ErrorClassSpec.hs b/test/ErrorClassSpec.hs --- a/test/ErrorClassSpec.hs +++ b/test/ErrorClassSpec.hs @@ -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. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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) + ] diff --git a/test/ShapeSpec.hs b/test/ShapeSpec.hs new file mode 100644 --- /dev/null +++ b/test/ShapeSpec.hs @@ -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 diff --git a/test/SseSpec.hs b/test/SseSpec.hs new file mode 100644 --- /dev/null +++ b/test/SseSpec.hs @@ -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 = [] + } diff --git a/test/ThinkingSpec.hs b/test/ThinkingSpec.hs new file mode 100644 --- /dev/null +++ b/test/ThinkingSpec.hs @@ -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" diff --git a/test/TransportSpec.hs b/test/TransportSpec.hs new file mode 100644 --- /dev/null +++ b/test/TransportSpec.hs @@ -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