diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026 Nadeem Bitar + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nadeem Bitar nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/baikai-claude.cabal b/baikai-claude.cabal new file mode 100644 --- /dev/null +++ b/baikai-claude.cabal @@ -0,0 +1,78 @@ +cabal-version: 3.4 +name: baikai-claude +version: 0.1.0.0 +synopsis: Anthropic Claude providers for the baikai abstraction +description: + Wraps the claude Haskell package as a Baikai Provider for both the Anthropic API and the + claude -p CLI. + +category: AI +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +build-type: Simple + +common common-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -fhide-source-paths -Wmissing-export-lists -Wpartial-fields + -Wmissing-deriving-strategies + + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + +library + import: common-options + hs-source-dirs: src + exposed-modules: + Baikai.Provider.Claude.Api + Baikai.Provider.Claude.Cli + Baikai.Provider.Claude.Interactive + + build-depends: + , aeson + , baikai ^>=0.1.0 + , base >=4.20 && <5 + , base64-bytestring + , bytestring + , claude + , containers + , cradle + , generic-lens + , http-client + , http-client-tls + , lens ^>=5.3 + , servant-client + , streamly >=0.11 && <0.13 + , streamly-core >=0.3 && <0.5 + , text ^>=2.1 + , time + , vector + +test-suite baikai-claude-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + -- cradle (used by Baikai.Provider.Claude.Interactive) requires the threaded RTS. + ghc-options: -threaded -with-rtsopts=-N + build-depends: + , baikai ^>=0.1.0 + , baikai-claude + , base >=4.20 && <5 + , bytestring + , generic-lens + , lens ^>=5.3 + , streamly-core >=0.3 && <0.5 + , tasty + , tasty-hunit + , text ^>=2.1 + , vector diff --git a/src/Baikai/Provider/Claude/Api.hs b/src/Baikai/Provider/Claude/Api.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Api.hs @@ -0,0 +1,764 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Provider wrapping the @claude@ package's Messages API. +-- +-- Call 'register' once (typically from @main@) to install the +-- 'Baikai.Api.AnthropicMessages' handler into the baikai provider +-- registry. After registration, any 'Baikai.Model.Model' whose +-- 'Baikai.Api.api' tag is 'AnthropicMessages' dispatches through +-- this handler. +-- +-- The handler resolves 'Baikai.Options.apiKey' when present, falling +-- back to the @ANTHROPIC_API_KEY@ env var via +-- 'Baikai.Auth.resolveApiKey'. +-- +-- EP-3 promotes streaming to the primary entry point. The handler +-- exposes a 'streamly' 'Stream' of 'AssistantMessageEvent' values +-- bridged from the upstream SDK's typed 'createMessageStreamTyped' +-- callback. The synchronous 'complete' field is derived via +-- 'streamingComplete', so callers that drain the stream get the +-- same fully-assembled 'Response' they had before. +module Baikai.Provider.Claude.Api + ( register, + registerWithRegistry, + claudeMessagesStream, + ) +where + +import Baikai.Api (Api (..)) +import Baikai.Auth qualified as Auth +import Baikai.CacheRetention (CacheRetention (..)) +import Baikai.Compat (AnthropicMessagesCompat (..)) +import Baikai.Content qualified as Content +import Baikai.Context (Context (..)) +import Baikai.Cost (_Cost) +import Baikai.Cost.Pricing qualified as Pricing +import Baikai.Message qualified as Msg +import Baikai.Model (Model, anthropicMessagesCompatFor) +import Baikai.Options (Options (..)) +import Baikai.Provider.Registry + ( ApiProvider (..), + ProviderRegistry, + globalProviderRegistry, + registerApiProviderWith, + ) +import Baikai.StopReason qualified as Stop +import Baikai.Stream (streamingComplete) +import Baikai.Stream.Event + ( AssistantMessageEvent (..), + BlockEndPayload (..), + DeltaPayload (..), + IndexPayload (..), + StartPayload (..), + TerminalPayload (..), + ToolCallEndPayload (..), + ) +import Baikai.ThinkingLevel (ThinkingLevel, thinkingTokenBudget) +import Baikai.Tool qualified as Tool +import Baikai.Usage qualified as Usage +import Claude.V1 qualified as Claude +import Claude.V1.Messages qualified as Messages +import Claude.V1.Tool qualified as ClaudeTool +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Exception (SomeException, displayException, try) +import Control.Lens ((%~), (&), (.~), (^.)) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Lazy qualified as BSL +import Data.Char (isAlphaNum, isAscii) +import Data.Generics.Labels () +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import GHC.Generics (Generic) +import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream qualified as Stream + +-- | Install the Anthropic Messages handler into the registry. +-- Calling 'register' twice keeps only the second handler — the +-- registry's insert-overwrites semantic. +register :: IO () +register = registerWithRegistry globalProviderRegistry + +-- | Install the Anthropic Messages handler into an explicit registry. +registerWithRegistry :: ProviderRegistry -> IO () +registerWithRegistry reg = + registerApiProviderWith + reg + ApiProvider + { apiTag = AnthropicMessages, + stream = claudeMessagesStream, + complete = streamingComplete claudeMessagesStream + } + +-- | Streaming producer for the Anthropic Messages API. +-- +-- Forks one worker thread per call that drives +-- 'Claude.createMessageStreamTyped'; the worker pushes typed +-- 'Messages.MessageStreamEvent' values onto a bounded 'Chan' +-- terminated by 'Nothing'. The returned 'Stream' is a translator: +-- it pulls raw events from the channel and emits zero or more +-- 'AssistantMessageEvent' values per upstream event, terminating +-- with exactly one 'EventDone' or 'EventError'. +-- +-- Producer-side exceptions (HTTP failure, decode failure inside the +-- SDK, etc.) are caught with 'try' and re-encoded into an +-- 'EventError' carrying whatever content was already assembled — +-- the masterplan's "partial output is always recoverable" promise. +claudeMessagesStream :: + Model -> Context -> Options -> Stream IO AssistantMessageEvent +claudeMessagesStream m ctx opts = + Stream.concatEffect $ do + setup <- prepareCall m ctx opts + case setup of + Left err -> pure (Stream.fromEffect (immediateError err)) + Right call -> do + ch <- newChan :: IO (Chan (Maybe Messages.MessageStreamEvent)) + tref <- newIORef False + _ <- forkIO (worker call ch tref) + startTime <- getCurrentTime + let initialState = + ProducerState + { chan = ch, + pending = [], + assembler = emptyAssembler m startTime, + finished = False, + terminalRef = tref + } + pure (Stream.unfoldrM step initialState) + +-- | Per-call prepared values: the typed SDK request, plus the +-- methods record to invoke the streaming endpoint. +data ClaudeCall = ClaudeCall + { methods :: !Claude.Methods, + request :: !Messages.CreateMessage + } + deriving stock (Generic) + +prepareCall :: + Model -> Context -> Options -> IO (Either Text ClaudeCall) +prepareCall m ctx opts = do + case mapRequest m ctx opts of + Left e -> pure (Left e) + Right req -> do + key <- resolveKey opts + let url = case m ^. #baseUrl of + "" -> "https://api.anthropic.com" + u -> u + env <- Claude.getClientEnv url + let mtds = Claude.makeMethods env key (Just "2023-06-01") + pure (Right ClaudeCall {methods = mtds, request = req}) + +resolveKey :: Options -> IO Text +resolveKey opts = case opts ^. #apiKey of + Just source -> Auth.resolveApiKey source + Nothing -> Auth.resolveApiKey (Auth.ApiKeyEnv "ANTHROPIC_API_KEY") + +-- | Worker body: drive the SDK's typed callback, forwarding events +-- onto the channel. Any exception is converted into a synthetic +-- @Error@ raw event so the consumer side can translate it through +-- the normal channel. After the SDK call returns (success or +-- handled failure) we close the channel with 'Nothing'. +worker :: + ClaudeCall -> + Chan (Maybe Messages.MessageStreamEvent) -> + IORef Bool -> + IO () +worker call ch _terminalRef = do + let Claude.Methods {Claude.createMessageStreamTyped = stream'} = call ^. #methods + r <- + try @SomeException $ + stream' (call ^. #request) $ \case + Left errText -> writeChan ch (Just (errorEvent errText)) + Right ev -> writeChan ch (Just ev) + case r of + Right () -> pure () + Left e -> writeChan ch (Just (errorEvent (Text.pack (displayException e)))) + writeChan ch Nothing + where + errorEvent :: Text -> Messages.MessageStreamEvent + errorEvent t = Messages.Error {Messages.error = Aeson.String t} + +-- | The streaming 'Stream' state. +data ProducerState = ProducerState + { chan :: !(Chan (Maybe Messages.MessageStreamEvent)), + pending :: ![AssistantMessageEvent], + assembler :: !Assembler, + finished :: !Bool, + terminalRef :: !(IORef Bool) + } + deriving stock (Generic) + +step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState)) +step s + | (e : rest) <- s ^. #pending = do + writeTerminal s e + pure + ( Just + ( e, + s + & #pending .~ rest + & #finished .~ (s ^. #finished || terminal e) + ) + ) + | s ^. #finished = pure Nothing + | otherwise = do + mRaw <- readChan (s ^. #chan) + case mRaw of + Nothing -> do + alreadyTerminal <- readIORef (s ^. #terminalRef) + if alreadyTerminal + then pure Nothing + else do + now <- getCurrentTime + let (ev, ass') = unexpectedEoS now (s ^. #assembler) + writeTerminal s ev + pure + ( Just + ( ev, + s & #assembler .~ ass' & #finished .~ True + ) + ) + Just raw -> do + now <- getCurrentTime + let (events, ass') = translate raw (s ^. #assembler) now + case events of + [] -> step (s & #assembler .~ ass') + (e : rest) -> do + writeTerminal s e + pure + ( Just + ( e, + s + & #pending .~ rest + & #assembler .~ ass' + & #finished .~ (s ^. #finished || terminal e) + ) + ) + +writeTerminal :: ProducerState -> AssistantMessageEvent -> IO () +writeTerminal s ev + | terminal ev = writeIORef (s ^. #terminalRef) True + | otherwise = pure () + +terminal :: AssistantMessageEvent -> Bool +terminal = \case + EventDone {} -> True + EventError {} -> True + _ -> False + +-- | The recovery path: channel closed before any terminal event. +unexpectedEoS :: UTCTime -> Assembler -> (AssistantMessageEvent, Assembler) +unexpectedEoS now ass = + let msg = + finalMessageOnError + ass + now + "claude stream ended without message_stop" + in (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}, ass) + +-- | Translation state across one streaming call. +data Assembler = Assembler + { model :: !Model, + start :: !UTCTime, + responseId :: !(Maybe Text), + closed :: !(IntMap Content.AssistantContent), + textBuf :: !(IntMap Text), + thinkBuf :: !(IntMap Text), + thinkSig :: !(IntMap Text), + toolArgsBuf :: !(IntMap Text), + toolMeta :: !(IntMap (Text, Text)), + usage :: !Usage.Usage, + stopReason :: !Stop.StopReason + } + deriving stock (Generic) + +emptyAssembler :: Model -> UTCTime -> Assembler +emptyAssembler m s = + Assembler + { model = m, + start = s, + responseId = Nothing, + closed = IntMap.empty, + textBuf = IntMap.empty, + thinkBuf = IntMap.empty, + thinkSig = IntMap.empty, + toolArgsBuf = IntMap.empty, + toolMeta = IntMap.empty, + usage = Usage._Usage, + stopReason = Stop.Stop + } + +translate :: + Messages.MessageStreamEvent -> + Assembler -> + UTCTime -> + ([AssistantMessageEvent], Assembler) +translate raw ass now = case raw of + Messages.Ping -> ([], ass) + Messages.Message_Start {Messages.message = mr} -> + let usage0 = anthroUsageToBaikai (mr ^. #usage) + ass' = ass & #responseId .~ Just (mr ^. #id) & #usage .~ usage0 + skeleton = skeletonMessage ass' now + in ([EventStart StartPayload {partial = skeleton}], ass') + Messages.Content_Block_Start {Messages.index = idx, Messages.content_block = block} -> + handleBlockStart (fromIntegral idx) block ass + Messages.Content_Block_Delta {Messages.index = idx, Messages.delta = d} -> + handleBlockDelta (fromIntegral idx) d ass + Messages.Content_Block_Stop {Messages.index = idx} -> + handleBlockStop (fromIntegral idx) ass + Messages.Message_Delta {Messages.message_delta = md, Messages.usage = su} -> + let stopR = mapStopReason (md ^. #stop_reason) + u = ass ^. #usage + outputTokensFinal = fromMaybe (u ^. #outputTokens) (Just (su ^. #output_tokens)) + u' = + u + & #outputTokens .~ outputTokensFinal + & #totalTokens + .~ ((u ^. #inputTokens) + outputTokensFinal + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens)) + in ([], ass & #stopReason .~ stopR & #usage .~ u') + Messages.Message_Stop -> + let msg = finalMessage ass now + in ([EventDone TerminalPayload {reason = ass ^. #stopReason, message = msg}], ass) + Messages.Error {Messages.error = errVal} -> + let errText = renderAnthropicError errVal + msg = finalMessageOnError ass now errText + in ([EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}], ass) + +handleBlockStart :: + Int -> + Messages.ContentBlock -> + Assembler -> + ([AssistantMessageEvent], Assembler) +handleBlockStart i block ass = case block of + Messages.ContentBlock_Text {} -> + ( [TextStart IndexPayload {contentIndex = i}], + ass & #textBuf %~ IntMap.insert i Text.empty + ) + Messages.ContentBlock_Thinking {} -> + ( [ThinkingStart IndexPayload {contentIndex = i}], + ass & #thinkBuf %~ IntMap.insert i Text.empty + ) + Messages.ContentBlock_Redacted_Thinking {} -> + ( [ThinkingStart IndexPayload {contentIndex = i}], + ass & #thinkBuf %~ IntMap.insert i Text.empty + ) + Messages.ContentBlock_Tool_Use {Messages.id = tid, Messages.name = tn} -> + ( [ToolCallStart IndexPayload {contentIndex = i}], + ass + & #toolArgsBuf %~ IntMap.insert i Text.empty + & #toolMeta %~ IntMap.insert i (tid, tn) + ) + _ -> + -- Server-tool, code-execution-tool, unknown — pass-through with no events. + ([], ass) + +handleBlockDelta :: + Int -> + Messages.ContentBlockDelta -> + Assembler -> + ([AssistantMessageEvent], Assembler) +handleBlockDelta i d ass = case d of + Messages.Delta_Text_Delta {Messages.text = t} -> + ( [TextDelta DeltaPayload {contentIndex = i, delta = t}], + ass & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i t + ) + Messages.Delta_Thinking_Delta {Messages.thinking = t} -> + ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}], + ass & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i t + ) + Messages.Delta_Signature_Delta {Messages.signature = sig} -> + -- Signatures are tail-end metadata on thinking blocks; they + -- attach to the ThinkingEnd event's content build, not a public + -- delta event. + ( [], + ass & #thinkSig %~ IntMap.insertWith (\new old -> old <> new) i sig + ) + Messages.Delta_Input_Json_Delta {Messages.partial_json = j} -> + ( [ToolCallDelta DeltaPayload {contentIndex = i, delta = j}], + ass & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i j + ) + +handleBlockStop :: + Int -> Assembler -> ([AssistantMessageEvent], Assembler) +handleBlockStop i ass + | Just body <- IntMap.lookup i (ass ^. #textBuf) = + let block = Content.AssistantText (Content.TextContent body) + in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}], + ass + & #closed %~ IntMap.insert i block + & #textBuf %~ IntMap.delete i + ) + | Just body <- IntMap.lookup i (ass ^. #thinkBuf) = + let sig = IntMap.lookup i (ass ^. #thinkSig) + block = + Content.AssistantThinking + Content.ThinkingContent + { Content.thinking = body, + Content.signature = if maybe True Text.null sig then Nothing else sig, + Content.redacted = False + } + in ( [ThinkingEnd BlockEndPayload {contentIndex = i, content = body}], + ass + & #closed %~ IntMap.insert i block + & #thinkBuf %~ IntMap.delete i + & #thinkSig %~ IntMap.delete i + ) + | Just argsText <- IntMap.lookup i (ass ^. #toolArgsBuf) = + let (tid, tn) = fromMaybe ("", "") (IntMap.lookup i (ass ^. #toolMeta)) + decoded :: Value + decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 argsText) of + Right v -> v + Left _ -> + -- Anthropic sometimes opens a tool_use block with an + -- empty input that never streams any delta. Fall back + -- to an empty object so the resulting ToolCall is + -- well-formed. + Aeson.Object mempty + tc = + Content.ToolCall + { Content.id_ = tid, + Content.name = tn, + Content.arguments = decoded + } + block = Content.AssistantToolCall tc + in ( [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}], + ass + & #closed %~ IntMap.insert i block + & #toolArgsBuf %~ IntMap.delete i + & #toolMeta %~ IntMap.delete i + ) + | otherwise = ([], ass) + +-- | The 'EventStart' message skeleton (empty content; usage/etc. +-- carried for downstream consumers that want metadata up front). +skeletonMessage :: Assembler -> UTCTime -> Msg.Message +skeletonMessage ass _now = + Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = Vector.empty, + Msg.usage = ass ^. #usage, + Msg.stopReason = Stop.Stop, + Msg.errorMessage = Nothing, + Msg.timestamp = ass ^. #start + } + +finalMessage :: Assembler -> UTCTime -> Msg.Message +finalMessage ass now = + let blocks = blocksInOrder ass + m = ass ^. #model + usageBare = ass ^. #usage + computed = Pricing.computeCost m usageBare + usage' = usageBare & #cost .~ computed + in Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = blocks, + Msg.usage = usage', + Msg.stopReason = ass ^. #stopReason, + Msg.errorMessage = Nothing, + Msg.timestamp = now + } + +finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message +finalMessageOnError ass now reason = + let blocks = blocksInOrder ass + m = ass ^. #model + usageBare = ass ^. #usage + computed = Pricing.computeCost m usageBare + usage' = usageBare & #cost .~ computed + in Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = blocks, + Msg.usage = usage', + Msg.stopReason = Stop.ErrorReason, + Msg.errorMessage = Just reason, + Msg.timestamp = now + } + +blocksInOrder :: Assembler -> Vector Content.AssistantContent +blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed)) + +-- | The immediate "request invalid" stream — emitted when +-- 'mapRequest' fails or 'prepareCall' is otherwise unable to build +-- a valid SDK request. +immediateError :: Text -> IO AssistantMessageEvent +immediateError errText = do + now <- getCurrentTime + let msg = + Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = Vector.empty, + Msg.usage = Usage._Usage, + Msg.stopReason = Stop.ErrorReason, + Msg.errorMessage = Just errText, + Msg.timestamp = now + } + pure (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}) + +renderAnthropicError :: Value -> Text +renderAnthropicError v = case v of + Aeson.String t -> t + _ -> Text.decodeUtf8 (BSL.toStrict (Aeson.encode v)) + +-- | Map the Anthropic streaming 'Message_Start.message.usage' value +-- into baikai's 'Usage' shape. Cache-related counters are populated +-- where present; cost is left at zero (the terminal event +-- recomputes it). +anthroUsageToBaikai :: Messages.Usage -> Usage.Usage +anthroUsageToBaikai u = + let i = u ^. #input_tokens + o = u ^. #output_tokens + cr = fromMaybe 0 (u ^. #cache_read_input_tokens) + cw = fromMaybe 0 (u ^. #cache_creation_input_tokens) + in Usage.Usage + { Usage.inputTokens = i, + Usage.outputTokens = o, + Usage.cacheReadTokens = cr, + Usage.cacheWriteTokens = cw, + Usage.reasoningTokens = Nothing, + Usage.totalTokens = i + o + cr + cw, + Usage.cost = _Cost + } + +-- ============================================================ +-- Request mapping (preserved from EP-2 with minor refactoring to +-- accept Context/Options directly). +-- ============================================================ + +mapRequest :: Model -> Context -> Options -> Either Text Messages.CreateMessage +mapRequest m ctx opts = do + msgs <- traverse mapMessage (Vector.toList (ctx ^. #messages)) + let compat = anthropicMessagesCompatFor m + baseTokens = fromMaybe (m ^. #maxOutputTokens) (opts ^. #maxTokens) + thinkingField = computeThinking m (opts ^. #thinking) + -- When extended thinking is enabled, Anthropic requires that + -- max_tokens be large enough to cover both the visible + -- response and the thinking budget. Bump the cap by the + -- requested budget so callers do not have to do the math. + maxTokensField_ = case thinkingField of + Just (Messages.ThinkingEnabled budget) -> baseTokens + budget + _ -> baseTokens + cacheControlField = computeCacheControl compat (opts ^. #cacheRetention) + -- `ToolChoiceNone` is not a first-class Anthropic value; the + -- standard way to disable tool use on a per-call basis is to + -- omit the @tools@ field entirely. Suppress both fields when + -- the caller asked for `None`. + suppressTools = case opts ^. #toolChoice of + Just Tool.ToolChoiceNone -> True + _ -> False + toolsVec = if suppressTools then Vector.empty else ctx ^. #tools + toolsField = + if Vector.null toolsVec + then Nothing + else Just (Vector.map (mkAnthropicTool compat) toolsVec) + toolChoiceField = case opts ^. #toolChoice of + Just Tool.ToolChoiceNone -> Nothing + Just tc -> Just (mkAnthropicToolChoice tc) + Nothing -> Nothing + pure + Messages._CreateMessage + { Messages.model = m ^. #modelId, + Messages.messages = Vector.fromList msgs, + Messages.max_tokens = maxTokensField_, + Messages.system = fmap Messages.SystemPromptText (ctx ^. #systemPrompt), + Messages.temperature = opts ^. #temperature, + Messages.tools = toolsField, + Messages.tool_choice = toolChoiceField, + Messages.cache_control = cacheControlField, + Messages.thinking = thinkingField + } + +-- | Translate the call-time 'Baikai.CacheRetention' preference into +-- the Anthropic SDK's @cache_control@ shape. +-- +-- 'CacheRetentionNone' (and 'Nothing') turn the field off entirely. +-- 'CacheRetentionShort' uses the ephemeral marker with no TTL (the +-- provider default). 'CacheRetentionLong' asks for the @"1h"@ TTL +-- when the host advertises 'supportsLongCacheRetention'; otherwise it +-- transparently downgrades to short retention. +computeCacheControl :: + AnthropicMessagesCompat -> + Maybe CacheRetention -> + Maybe Messages.CacheControl +computeCacheControl _ Nothing = Nothing +computeCacheControl _ (Just CacheRetentionNone) = Nothing +computeCacheControl _ (Just CacheRetentionShort) = + Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing} +computeCacheControl compat (Just CacheRetentionLong) + | supportsLongCacheRetention compat = + Just + Messages.CacheControl + { Messages.type_ = "ephemeral", + Messages.ttl = Just (Messages.CacheTTLDuration "1h") + } + | otherwise = + Just Messages.CacheControl {Messages.type_ = "ephemeral", Messages.ttl = Nothing} + +-- | Translate the call-time 'Baikai.ThinkingLevel' preference into +-- the Anthropic SDK's 'Messages.Thinking' shape. +-- +-- We only enable the thinking field when the chosen model advertises +-- 'reasoning' support — sending a thinking config to a non-reasoning +-- model is a 400 error from Anthropic, not a silent no-op. Callers +-- that asked for thinking on a non-reasoning model get the request +-- shaped without it (the request still succeeds and returns a normal +-- response). +computeThinking :: Model -> Maybe ThinkingLevel -> Maybe Messages.Thinking +computeThinking _ Nothing = Nothing +computeThinking m (Just lvl) + | m ^. #reasoning = + Just Messages.ThinkingEnabled {Messages.budget_tokens = thinkingTokenBudget lvl} + | otherwise = Nothing + +-- | Map a baikai 'Tool.Tool' into the upstream Anthropic +-- 'ClaudeTool.ToolDefinition'. The JSON Schema is passed through +-- verbatim; 'ClaudeTool.functionTool' extracts @properties@ and +-- @required@ off the top-level schema if present. +-- +-- The compat record is threaded through so future revisions can +-- apply per-tool @cache_control@ markers (when +-- 'supportsCacheControlOnTools' is True) or per-tool eager input +-- streaming flags. EP-5 ships the parameter at its default, leaving +-- the upstream tool definition without cache markers. +mkAnthropicTool :: AnthropicMessagesCompat -> Tool.Tool -> ClaudeTool.ToolDefinition +mkAnthropicTool _compat t = + ClaudeTool.inlineTool + ( ClaudeTool.functionTool + (Tool.name t) + (Just (Tool.description t)) + (Tool.parameters t) + ) + +-- | Map a baikai 'Tool.ToolChoice' into the upstream Anthropic +-- 'ClaudeTool.ToolChoice'. 'Tool.ToolChoiceNone' is handled at the +-- call site by suppressing the @tools@ field — it never reaches +-- this function. 'Tool.ToolChoiceRequired' maps to Anthropic's +-- @any@ which is the closest equivalent ("must call some tool"). +mkAnthropicToolChoice :: Tool.ToolChoice -> ClaudeTool.ToolChoice +mkAnthropicToolChoice = \case + Tool.ToolChoiceAuto -> ClaudeTool.ToolChoice_Auto + Tool.ToolChoiceRequired -> ClaudeTool.ToolChoice_Any + Tool.ToolChoiceSpecific n -> ClaudeTool.ToolChoice_Tool {ClaudeTool.name = n} + -- Unreachable: ToolChoiceNone is suppressed in 'mapRequest'. + Tool.ToolChoiceNone -> ClaudeTool.ToolChoice_Auto + +-- | Anthropic enforces @[a-zA-Z0-9_-]+@ on tool-call ids and caps +-- their length at 64 characters. Callers may have used any +-- naming convention, so the provider boundary normalizes here +-- whenever an id is round-tripped back to Anthropic — both on +-- assistant turn replay ('Content_Tool_Use') and on tool-result +-- messages ('Content_Tool_Result'). +normalizeToolCallId :: Text -> Text +normalizeToolCallId = + Text.take 64 . Text.map sanitise + where + sanitise c + | isAscii c && isAlphaNum c = c + | c == '_' || c == '-' = c + | otherwise = '_' + +mapMessage :: Msg.Message -> Either Text Messages.Message +mapMessage = \case + Msg.UserMessage Msg.UserPayload {Msg.content = uc} -> + Right + Messages.Message + { Messages.role = Messages.User, + Messages.content = Vector.mapMaybe userContentToBlock uc, + Messages.cache_control = Nothing + } + Msg.AssistantMessage Msg.AssistantPayload {Msg.content = ac} -> + Right + Messages.Message + { Messages.role = Messages.Assistant, + Messages.content = Vector.mapMaybe assistantContentToBlock ac, + Messages.cache_control = Nothing + } + Msg.ToolResultMessage + Msg.ToolResultPayload + { Msg.toolCallId = tid, + Msg.content = trc, + Msg.isError = err + } -> + case concatToolResultText trc of + Left unsupported -> Left unsupported + Right body -> + Right + Messages.Message + { Messages.role = Messages.User, + Messages.content = + Vector.singleton + Messages.Content_Tool_Result + { Messages.tool_use_id = normalizeToolCallId tid, + Messages.content = nonEmpty body, + Messages.is_error = Just err + }, + Messages.cache_control = Nothing + } + +userContentToBlock :: Content.UserContent -> Maybe Messages.Content +userContentToBlock = \case + Content.UserText (Content.TextContent t) -> + Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} + Content.UserImage img -> + Just + Messages.Content_Image + { Messages.source = + Messages.ImageSource + { Messages.type_ = "base64", + Messages.media_type = Content.mimeType img, + Messages.data_ = Text.decodeUtf8 (Base64.encode (Content.imageData img)) + }, + Messages.cache_control = Nothing + } + +assistantContentToBlock :: Content.AssistantContent -> Maybe Messages.Content +assistantContentToBlock = \case + Content.AssistantText (Content.TextContent t) -> + Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} + Content.AssistantThinking th -> + Just + Messages.Content_Thinking + { Messages.thinking = Content.thinking th, + Messages.signature = fromMaybe "" (Content.signature th) + } + Content.AssistantToolCall tc -> + Just + Messages.Content_Tool_Use + { Messages.id = normalizeToolCallId (Content.id_ tc), + Messages.name = Content.name tc, + Messages.input = Content.arguments tc, + Messages.caller = Nothing + } + +concatToolResultText :: Vector Content.ToolResultContent -> Either Text Text +concatToolResultText = + fmap (Text.concat . Vector.toList) . traverse oneBlock + where + oneBlock = \case + Content.ToolResultText (Content.TextContent t) -> Right t + Content.ToolResultImage _ -> + Left "Anthropic Messages cannot encode ToolResultImage blocks in tool-result messages" + +nonEmpty :: Text -> Maybe Text +nonEmpty t + | Text.null t = Nothing + | otherwise = Just t + +mapStopReason :: Maybe Messages.StopReason -> Stop.StopReason +mapStopReason = \case + Just Messages.End_Turn -> Stop.Stop + Just Messages.Max_Tokens -> Stop.Length + Just Messages.Stop_Sequence -> Stop.Stop + Just Messages.Tool_Use -> Stop.ToolUse + Just Messages.Refusal -> Stop.ErrorReason + Just Messages.Model_Context_Window_Exceeded -> Stop.Length + Nothing -> Stop.Stop diff --git a/src/Baikai/Provider/Claude/Cli.hs b/src/Baikai/Provider/Claude/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Cli.hs @@ -0,0 +1,208 @@ +-- | Provider that drives the @claude -p@ non-interactive CLI as a +-- subprocess. +-- +-- Call 'register' once (typically from @main@) to install the +-- 'Baikai.Api.AnthropicMessagesCli' handler with default config. +-- For non-default executable paths or extra args, use 'registerWith' +-- and supply a custom 'ClaudeCliConfig'. +-- +-- The CLI provider always returns a 'Response' whose embedded +-- assistant message carries zero token counts (and therefore zero +-- cost): the @claude@ CLI runs under a flat subscription, so +-- per-token billing does not apply. CLI providers do not participate +-- in tool calling — the masterplan's Decision Log records the +-- reasoning. +module Baikai.Provider.Claude.Cli + ( ClaudeCliConfig (..), + defaultClaudeCliConfig, + register, + registerWith, + registerWithRegistry, + registerWithRegistryAndConfig, + ) +where + +import Baikai.Api (Api (..)) +import Baikai.Content (AssistantContent (..), TextContent (..)) +import Baikai.Context (Context (..)) +import Baikai.Error (BaikaiError (..)) +import Baikai.Message (AssistantPayload (..)) +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Provider.Cli.Internal qualified as Internal +import Baikai.Provider.Registry + ( ApiProvider (..), + ProviderRegistry, + globalProviderRegistry, + registerApiProviderWith, + ) +import Baikai.Response qualified as Resp +import Baikai.StopReason (StopReason (..)) +import Baikai.Stream (liftCompleteToStream) +import Baikai.Usage (_Usage) +import Control.Exception (throwIO) +import Control.Lens ((^.)) +import Cradle + ( ExitCode (..), + StderrRaw (..), + StdoutRaw (..), + addArgs, + cmd, + run, + setNoStdin, + setWorkingDir, + ) +import Data.Aeson (FromJSON, Value (..), eitherDecodeStrict) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (parseEither, parseJSON) +import Data.ByteString (ByteString) +import Data.Function ((&)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import GHC.Generics (Generic) + +-- | Configuration for the @claude -p@ subprocess. +data ClaudeCliConfig = ClaudeCliConfig + { executable :: !FilePath, + extraArgs :: !(Vector Text), + workingDir :: !(Maybe FilePath) + } + deriving stock (Eq, Show, Generic) + +defaultClaudeCliConfig :: ClaudeCliConfig +defaultClaudeCliConfig = + ClaudeCliConfig + { executable = "claude", + extraArgs = mempty, + workingDir = Nothing + } + +-- | Install the CLI handler with 'defaultClaudeCliConfig'. +register :: IO () +register = registerWith defaultClaudeCliConfig + +-- | Install the CLI handler with a caller-supplied config. +-- +-- The CLI binary runs in batch mode; there is no intra-response +-- streaming on the wire. The 'stream' field therefore wraps the +-- batch 'runClaudeCli' through 'liftCompleteToStream', producing a +-- synthetic one-shot event stream +-- (@EventStart, TextStart 0, TextDelta 0 body, TextEnd 0, EventDone@) +-- the moment the subprocess returns. 'complete' is left as the +-- direct batch path so it preserves 'Response.responseId' and the +-- measured 'Response.latencyMs' (going through a +-- 'streamingComplete' round trip would lose the former and recompute +-- the latter from synthetic events). EP-3's Decision Log explains +-- the deviation from the plan's "complete = streamingComplete . +-- stream" default. +registerWith :: ClaudeCliConfig -> IO () +registerWith = registerWithRegistryAndConfig globalProviderRegistry + +-- | Install the CLI handler with 'defaultClaudeCliConfig' into an explicit +-- registry. +registerWithRegistry :: ProviderRegistry -> IO () +registerWithRegistry reg = registerWithRegistryAndConfig reg defaultClaudeCliConfig + +-- | Install the CLI handler with a caller-supplied config into an explicit +-- registry. +registerWithRegistryAndConfig :: ProviderRegistry -> ClaudeCliConfig -> IO () +registerWithRegistryAndConfig reg cfg = + registerApiProviderWith + reg + ApiProvider + { apiTag = AnthropicMessagesCli, + stream = liftCompleteToStream (runClaudeCli cfg), + complete = runClaudeCli cfg + } + +-- | The shape of @claude -p --output-format json@ stdout. +data ClaudeCliResult = ClaudeCliResult + { result :: !Text, + is_error :: !Bool, + session_id :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +systemPromptArgs :: Context -> [String] +systemPromptArgs ctx = case ctx ^. #systemPrompt of + Nothing -> [] + Just sp -> ["--system-prompt", Text.unpack sp] + +modelArgs :: Model -> [String] +modelArgs m = case Text.strip (m ^. #modelId) of + "" -> [] + mid -> ["--model", Text.unpack mid] + +decodeResult :: ByteString -> IO ClaudeCliResult +decodeResult bs = case eitherDecodeStrict bs of + Left err -> throwIO (DecodeError (Text.pack err)) + Right (Aeson.Array events) -> case findResultEvent events of + Nothing -> throwIO (DecodeError "claude -p: no result event in stdout array") + Just ev -> case parseEither parseJSON ev of + Left err -> throwIO (DecodeError (Text.pack err)) + Right r -> pure r + Right v@(Aeson.Object _) -> case parseEither parseJSON v of + Left err -> throwIO (DecodeError (Text.pack err)) + Right r -> pure r + Right _ -> throwIO (DecodeError "claude -p: expected JSON object or array") + +findResultEvent :: Vector Value -> Maybe Value +findResultEvent = Vector.find isResult + where + isResult (Aeson.Object o) = case KeyMap.lookup "type" o of + Just (Aeson.String "result") -> True + _ -> False + isResult _ = False + +runClaudeCli :: ClaudeCliConfig -> Model -> Context -> Options -> IO Resp.Response +runClaudeCli cfg m ctx _opts = do + let prompt = Internal.renderPrompt ctx + args = + ["-p"] + <> modelArgs m + <> ["--output-format", "json", "--no-session-persistence"] + <> systemPromptArgs ctx + <> fmap Text.unpack (Vector.toList (cfg ^. #extraArgs)) + <> [Text.unpack prompt] + start <- getCurrentTime + (exitCode, StdoutRaw out, StderrRaw err) <- + run $ + cmd (cfg ^. #executable) + & addArgs args + & setNoStdin + & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir + end <- getCurrentTime + case exitCode of + ExitFailure n -> throwIO (ProcessError n (Internal.decodeUtf8Lenient err)) + ExitSuccess -> do + r <- decodeResult out + if is_error r + then throwIO (ProviderError (result r)) + else pure (mkResponse m start end (result r)) + +mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response +mkResponse m start end body = + Resp.Response + { Resp.message = + AssistantPayload + { content = Vector.singleton (AssistantText (TextContent body)), + usage = _Usage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = end + }, + Resp.model = m, + Resp.api = AnthropicMessagesCli, + Resp.provider = m ^. #provider, + Resp.responseId = Nothing, + Resp.latencyMs = millisBetween start end + } + +millisBetween :: UTCTime -> UTCTime -> Integer +millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double)) diff --git a/src/Baikai/Provider/Claude/Interactive.hs b/src/Baikai/Provider/Claude/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Interactive.hs @@ -0,0 +1,94 @@ +-- | Launch real interactive Claude Code sessions from Baikai's +-- provider-neutral interactive request type. +-- +-- This module is intentionally separate from +-- "Baikai.Provider.Claude.Cli": that module drives @claude -p@ as a +-- batch completion provider, while this module starts the interactive +-- terminal UI and returns only after the CLI exits. +module Baikai.Provider.Claude.Interactive + ( ClaudeInteractiveConfig (..), + defaultClaudeInteractiveConfig, + claudeInteractiveCommand, + launchClaudeInteractive, + ) +where + +import Baikai.Interactive + ( InteractiveLaunchRequest (..), + InteractiveLaunchResult, + InteractiveProvider (..), + InteractiveSafety (..), + _InteractiveLaunchResult, + ) +import Baikai.Prelude +import Cradle (addArgs, cmd, run, setWorkingDir) +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Vector qualified as Vector + +-- | Configuration for the interactive @claude@ process. +data ClaudeInteractiveConfig = ClaudeInteractiveConfig + { executable :: !FilePath, + extraArgs :: !(Vector Text) + } + deriving stock (Eq, Show, Generic) + +defaultClaudeInteractiveConfig :: ClaudeInteractiveConfig +defaultClaudeInteractiveConfig = + ClaudeInteractiveConfig + { executable = "claude", + extraArgs = mempty + } + +-- | Render the executable and arguments for an interactive Claude +-- Code launch. The final positional argument is the initial user +-- prompt. +claudeInteractiveCommand :: + ClaudeInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String]) +claudeInteractiveCommand cfg req = + ( cfg ^. #executable, + modelArgs req + <> systemPromptArgs req + <> extraDirArgs req + <> safetyArgs req + <> fmap Text.unpack (Vector.toList (cfg ^. #extraArgs)) + <> fmap Text.unpack (req ^. #extraArgs) + <> [Text.unpack (req ^. #userPrompt)] + ) + +-- | Launch Claude Code with inherited stdin, stdout, and stderr so +-- the local CLI owns the interactive terminal experience. +launchClaudeInteractive :: + ClaudeInteractiveConfig -> InteractiveLaunchRequest -> IO InteractiveLaunchResult +launchClaudeInteractive cfg req = do + let (exe, args) = claudeInteractiveCommand cfg req + code <- + run $ + cmd exe + & addArgs args + & maybe id setWorkingDir (req ^. #workingDir) + pure (_InteractiveLaunchResult InteractiveClaude code) + +modelArgs :: InteractiveLaunchRequest -> [String] +modelArgs req = case Text.strip <$> req ^. #model of + Nothing -> [] + Just "" -> [] + Just mid -> ["--model", Text.unpack mid] + +systemPromptArgs :: InteractiveLaunchRequest -> [String] +systemPromptArgs req = case Text.strip <$> req ^. #systemPrompt of + Nothing -> [] + Just "" -> [] + Just prompt -> ["--system-prompt", Text.unpack prompt] + +extraDirArgs :: InteractiveLaunchRequest -> [String] +extraDirArgs req = + concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs) + +safetyArgs :: InteractiveLaunchRequest -> [String] +safetyArgs req = case req ^. #safety of + ClaudeAllowedTools [] -> [] + ClaudeAllowedTools tools -> + ["--allowedTools", Text.unpack (Text.intercalate "," tools)] + DefaultSafety -> [] + CodexSandbox _ _ -> [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,100 @@ +module Main (main) where + +import Baikai +import Baikai.Provider.Claude.Api +import Baikai.Provider.Claude.Interactive +import Control.Lens ((&), (.~), (^.)) +import Data.ByteString.Char8 qualified as BS8 +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +main :: IO () +main = + defaultMain $ + testGroup + "Baikai.Provider.Claude.Interactive" + [ commandRenderingTest, + compatDetectionTest, + rejectsImageToolResultsTest + ] + +commandRenderingTest :: TestTree +commandRenderingTest = + testCase "renders model, prompt, directories, allowed tools, and extra args" $ do + let cfg = + defaultClaudeInteractiveConfig + { executable = "/bin/claude", + extraArgs = Vector.fromList ["--debug"] + } + req = + (_InteractiveLaunchRequest "inspect the repo") + & #systemPrompt .~ Just "Be terse." + & #model .~ Just "sonnet" + & #workingDir .~ Just "/work/project" + & #extraDirs .~ ["/work/shared", "/work/docs"] + & #safety .~ ClaudeAllowedTools ["Read", "Bash(git status)"] + & #extraArgs .~ ["--permission-mode", "plan"] + claudeInteractiveCommand cfg req + @?= ( "/bin/claude", + [ "--model", + "sonnet", + "--system-prompt", + "Be terse.", + "--add-dir", + "/work/shared", + "--add-dir", + "/work/docs", + "--allowedTools", + "Read,Bash(git status)", + "--debug", + "--permission-mode", + "plan", + "inspect the repo" + ] + ) + +compatDetectionTest :: TestTree +compatDetectionTest = + testCase "Anthropic-compatible hosts auto-detect request-shaping compat flags" $ do + let model = + _Model + & #api .~ AnthropicMessages + & #baseUrl .~ "https://api.fireworks.ai/inference/v1" + compat = anthropicMessagesCompatFor model + compat ^. #supportsCacheControlOnTools @?= False + compat ^. #sendSessionAffinityHeaders @?= True + compat ^. #supportsLongCacheRetention @?= False + +rejectsImageToolResultsTest :: TestTree +rejectsImageToolResultsTest = + testCase "Claude API mapping rejects image tool-result blocks instead of dropping them" $ do + let model = + _Model + & #modelId .~ "claude-test" + & #api .~ AnthropicMessages + & #provider .~ "anthropic" + image = ImageContent {imageData = BS8.pack "png-bytes", mimeType = "image/png"} + ctx = + _Context + & #messages + .~ Vector.singleton + ( ToolResultMessage + ToolResultPayload + { toolCallId = "call_1", + toolName = "render", + content = Vector.singleton (ToolResultImage image), + isError = False, + timestamp = read "2026-06-05 00:00:00 UTC" + } + ) + events <- Stream.toList (claudeMessagesStream model ctx _Options) + case events of + [EventError TerminalPayload {message = AssistantMessage AssistantPayload {errorMessage = Just msg}}] -> + assertBool + ("expected ToolResultImage error, got: " <> Text.unpack msg) + ("ToolResultImage" `Text.isInfixOf` msg) + other -> error ("expected one EventError; got: " <> show other)