diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.0.0: + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2025, Mercury + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its + 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 HOLDER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,107 @@ +# `claude` + +Haskell bindings to Anthropic's Claude API using `servant`. + +## Example usage + +```haskell +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +import Claude.V1 +import Claude.V1.Messages +import Data.Foldable (traverse_) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified System.Environment as Environment + +main :: IO () +main = do + key <- Environment.getEnv "ANTHROPIC_KEY" + clientEnv <- getClientEnv "https://api.anthropic.com" + let Methods{ createMessage } = makeMethods clientEnv (Text.pack key) (Just "2023-06-01") + + MessageResponse{ content } <- createMessage _CreateMessage + { model = "claude-sonnet-4-5-20250929" + , messages = [ Message{ role = User, content = [ textContent "Hello!" ] } ] + , max_tokens = 1024 + } + + let display (ContentBlock_Text{ text }) = Text.IO.putStrLn text + display _ = pure () + traverse_ display content +``` + +## Setup + +### Using Nix with Flakes (Recommended) + +1. Ensure you have Nix with flakes enabled +2. Copy the sample environment file: + +```bash +cp .envrc.sample .envrc +``` + +3. Edit `.envrc` with your Anthropic API key +4. Run `direnv allow` + +### Manual Setup + +```bash +cabal build +``` + +## Environment Variables + +Set your Anthropic API key as an environment variable: + +```bash +# Option 1: Set directly in your shell +export ANTHROPIC_KEY="your-anthropic-api-key" + +# Option 2: Using .envrc with direnv (recommended) +cp .envrc.sample .envrc +# Edit .envrc to add your API key +direnv allow +``` + +The API key is needed for running the test suite and example programs. + +## Testing + +Run the test suite: + +```bash +cabal test +``` + +## Running the Examples + +```bash +cabal run claude-example +cabal run claude-stream-example +cabal run claude-tool-example +cabal run claude-vision-example +cabal run claude-tool-search-example +cabal run claude-programmatic-tool-calling-example +``` + +### Advanced Examples + +The `claude-tool-search-example` and `claude-programmatic-tool-calling-example` demonstrate beta features that require the `advanced-tool-use-2025-11-20` beta header: + +- **[Tool Search Tool](https://platform.claude.com/docs/en/agents-and-tools/tool-use/tool-search-tool)**: Server-side tool search for efficiently handling large numbers of tools +- **[Programmatic Tool Calling (PTC)](https://platform.claude.com/docs/en/agents-and-tools/tool-use/programmatic-tool-calling)**: Claude writes and executes code to call multiple tools and aggregate results + +To enable these features, use `makeMethodsWith` with the beta header: + +```haskell +let options = defaultClientOptions + { apiKey = key + , anthropicBeta = Just "advanced-tool-use-2025-11-20" + } +let Methods{ createMessage } = makeMethodsWith clientEnv options +``` diff --git a/claude.cabal b/claude.cabal new file mode 100644 --- /dev/null +++ b/claude.cabal @@ -0,0 +1,174 @@ +cabal-version: 2.4 +name: claude +version: 1.0.0 +synopsis: Servant bindings to Anthropic's Claude API +description: This package provides comprehensive and type-safe bindings + to Anthropic's Claude API, providing both a Servant interface + and non-Servant interface for convenience. + . + Read the @README@ below for a fully worked usage example. + . + Otherwise, browse the "Claude.V1" module, which is the + intended package entrypoint. +license: BSD-3-Clause +license-file: LICENSE +author: Paul-Arthur Asselin +maintainer: pa@mercury.com +category: AI, API, LLM +copyright: 2025 +build-type: Simple +extra-doc-files: README.md + , CHANGELOG.md + +source-repository head + type: git + location: https://github.com/MercuryTechnologies/claude + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base >=4.15.0.0 && <5 + , aeson >=2.0 && <2.3 + , bytestring >=0.10 && <0.13 + , containers >=0.6 && <0.8 + , filepath >=1.4 && <1.6 + , http-api-data >=0.4 && <0.7 + , http-client >=0.7 && <0.8 + , http-client-tls >=0.3 && <0.4 + , http-types >=0.12 && <0.13 + , servant >=0.19 && <0.21 + , servant-client >=0.19 && <0.21 + , text >=1.2 && <2.2 + , time >=1.9 && <1.15 + , vector >=0.12 && <0.14 + exposed-modules: Claude.V1 + Claude.V1.Error + Claude.V1.Messages + Claude.V1.Messages.Batches + Claude.V1.Tool + other-modules: Claude.Prelude + default-extensions: DataKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , DuplicateRecordFields + , FlexibleInstances + , GeneralizedNewtypeDeriving + , OverloadedLists + , OverloadedStrings + , RecordWildCards + , MultiParamTypeClasses + , NamedFieldPuns + , TypeApplications + , TypeOperators + , ViewPatterns + ghc-options: -Wall -Wno-missing-fields + +test-suite tasty + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs + build-depends: base + , aeson + , claude + , http-client + , http-client-tls + , servant-client + , tasty + , tasty-hunit + , text + , vector + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + , RecordWildCards + ghc-options: -Wall + +executable claude-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-example + main-is: Main.hs + build-depends: base + , claude + , text + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall + +executable claude-stream-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-stream-example + main-is: Main.hs + build-depends: base + , aeson + , claude + , text + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall + +executable claude-tool-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-tool-example + main-is: Main.hs + build-depends: base + , aeson + , bytestring + , claude + , text + , vector + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall + +executable claude-vision-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-vision-example + main-is: Main.hs + build-depends: base + , base64-bytestring >=1.0 && <1.3 + , bytestring + , claude + , text + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall + +executable claude-tool-search-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-tool-search-example + main-is: Main.hs + build-depends: base + , aeson + , claude + , text + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall + +executable claude-programmatic-tool-calling-example + default-language: Haskell2010 + hs-source-dirs: examples/claude-programmatic-tool-calling-example + main-is: Main.hs + build-depends: base + , aeson + , claude + , text + , vector + default-extensions: DuplicateRecordFields + , NamedFieldPuns + , OverloadedLists + , OverloadedStrings + ghc-options: -Wall diff --git a/examples/claude-example/Main.hs b/examples/claude-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-example/Main.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Claude.V1 +import Claude.V1.Messages +import Data.Foldable (traverse_) + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified System.Environment as Environment + +main :: IO () +main = do + key <- Environment.getEnv "ANTHROPIC_KEY" + + clientEnv <- getClientEnv "https://api.anthropic.com" + + let Methods{ createMessage } = makeMethods clientEnv (Text.pack key) (Just "2023-06-01") + + Text.IO.putStrLn "Enter your message:" + text <- Text.IO.getLine + + MessageResponse{ content } <- createMessage _CreateMessage + { model = "claude-sonnet-4-5-20250929" + , messages = + [ Message + { role = User + , content = [ textContent text ] + , cache_control = Nothing + } + ] + , max_tokens = 1024 + } + + let display (ContentBlock_Text{ text = t }) = Text.IO.putStrLn t + display _ = pure () + + traverse_ display content diff --git a/examples/claude-programmatic-tool-calling-example/Main.hs b/examples/claude-programmatic-tool-calling-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-programmatic-tool-calling-example/Main.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Example demonstrating Programmatic Tool Calling (PTC) with Claude +-- +-- This example shows how to use code execution to have Claude programmatically +-- call tools. Instead of Claude making individual tool calls that you handle +-- one by one, Claude writes and executes code that calls multiple tools and +-- aggregates the results. +-- +-- Requirements: +-- * anthropic-beta: advanced-tool-use-2025-11-20 header +-- * code_execution_20250825 tool in the tools array +-- * Tools must have allowed_callers = ["code_execution_20250825"] +module Main where + +import Data.Foldable (toList) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Prelude hiding (id) + +import qualified Claude.V1 as V1 +import qualified Claude.V1.Messages as Messages +import qualified Claude.V1.Tool as Tool +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson.Types +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Vector as Vector +import qualified System.Environment as Environment + +-- | Define a query_database tool that Claude can call programmatically +queryDatabaseTool :: Tool.Tool +queryDatabaseTool = Tool.Tool + { Tool.name = "query_database" + , Tool.description = Just "Query a regional database for sales data. Returns sales figures for the specified region." + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "region" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("The region to query: west, east, or central" :: Text) + , "enum" Aeson..= (["west", "east", "central"] :: [Text]) + ] + ] + , Tool.required = Just ["region"] + } + } + +-- | Fake database query - returns sales data for a region +queryDatabase :: Text -> Text +queryDatabase region = case region of + "west" -> "{\"region\": \"west\", \"sales\": 125000, \"units\": 450}" + "east" -> "{\"region\": \"east\", \"sales\": 198000, \"units\": 720}" + "central" -> "{\"region\": \"central\", \"sales\": 87000, \"units\": 310}" + _ -> "{\"error\": \"Unknown region\"}" + +main :: IO () +main = do + key <- Text.pack <$> Environment.getEnv "ANTHROPIC_KEY" + env <- V1.getClientEnv "https://api.anthropic.com" + + -- Create methods with beta header for PTC + let options = V1.defaultClientOptions + { V1.apiKey = key + , V1.anthropicBeta = Just "advanced-tool-use-2025-11-20" + } + let V1.Methods{ V1.createMessage } = V1.makeMethodsWith env options + + -- Tools: code execution + query_database with allowed_callers + let tools = + [ Tool.codeExecutionTool + , Tool.allowCallers Tool.allowedCallersCodeExecution (Tool.inlineTool queryDatabaseTool) + ] + + -- Initial message asking for aggregated data from multiple regions + let initialMessage = Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent + "Query the database for all three regions (west, east, central) and calculate the total sales and units across all regions. Use code execution to make the queries and aggregate the results." + ] + , Messages.cache_control = Nothing + } + + Text.IO.putStrLn "=== Programmatic Tool Calling Example ===" + Text.IO.putStrLn "Sending request with code execution tool..." + Text.IO.putStrLn "" + + -- Loop until we get a final response + loop createMessage tools [initialMessage] Nothing 0 + + where + maxIterations :: Int + maxIterations = 10 + + loop _ _ _ _ iteration | iteration >= maxIterations = do + Text.IO.putStrLn $ "Max iterations (" <> Text.pack (show maxIterations) <> ") reached" + + loop createMessage tools messages containerId iteration = do + Text.IO.putStrLn $ "--- Turn " <> Text.pack (show (iteration + 1)) <> " ---" + + response <- createMessage Messages._CreateMessage + { Messages.model = "claude-sonnet-4-5-20250929" + , Messages.messages = Vector.fromList messages + , Messages.max_tokens = 4096 + , Messages.tools = Just tools + , Messages.container = containerId + } + + let Messages.MessageResponse + { Messages.stop_reason = stopReason + , Messages.content = responseContent + , Messages.container = containerInfo + } = response + + -- Extract container ID for reuse + let newContainerId = case containerInfo of + Just Messages.ContainerInfo{ Messages.id = cid } -> Just cid + Nothing -> containerId + + Text.IO.putStrLn $ "Stop reason: " <> Text.pack (show stopReason) + when (containerId /= newContainerId) $ + Text.IO.putStrLn $ "Container ID: " <> maybe "none" (\x -> x) newContainerId + + -- Print response content + mapM_ printContentBlock (toList responseContent) + + case stopReason of + Just Messages.End_Turn -> do + Text.IO.putStrLn "" + Text.IO.putStrLn "=== Final Response ===" + mapM_ printFinalContent (toList responseContent) + + Just Messages.Tool_Use -> do + -- Find all tool_use blocks and process them + let toolUseBlocks = + [ (toolId, toolName, toolInput, toolCaller) + | Messages.ContentBlock_Tool_Use + { Messages.id = toolId + , Messages.name = toolName + , Messages.input = toolInput + , Messages.caller = toolCaller + } <- toList responseContent + ] + + Text.IO.putStrLn "" + Text.IO.putStrLn $ "Processing " <> Text.pack (show (length toolUseBlocks)) <> " tool call(s)..." + + -- Process each tool call + toolResults <- mapM processToolCall toolUseBlocks + + -- Build assistant replay message + let assistantContent = mapMaybe Messages.contentBlockToContent (toList responseContent) + let assistantMessage = Messages.Message + { Messages.role = Messages.Assistant + , Messages.content = Vector.fromList assistantContent + , Messages.cache_control = Nothing + } + + -- Build user message with tool results only (required for PTC) + let userMessage = Messages.Message + { Messages.role = Messages.User + , Messages.content = Vector.fromList toolResults + , Messages.cache_control = Nothing + } + + Text.IO.putStrLn "" + loop createMessage tools + (messages <> [assistantMessage, userMessage]) + newContainerId + (iteration + 1) + + _ -> do + Text.IO.putStrLn $ "Unexpected stop reason: " <> Text.pack (show stopReason) + + when :: Bool -> IO () -> IO () + when True action = action + when False _ = pure () + +-- | Process a single tool call +processToolCall :: (Text, Text, Aeson.Value, Maybe Messages.ToolCaller) -> IO Messages.Content +processToolCall (toolId, toolName, toolInput, caller) = do + -- Show caller info + case caller of + Just Messages.ToolCaller_Direct -> + Text.IO.putStrLn $ " [Direct call] " <> toolName + Just (Messages.ToolCaller_CodeExecution{ Messages.tool_id = tid }) -> + Text.IO.putStrLn $ " [Code execution call via " <> tid <> "] " <> toolName + Just (Messages.ToolCaller_Unknown _) -> + Text.IO.putStrLn $ " [Unknown caller] " <> toolName + Nothing -> + Text.IO.putStrLn $ " [No caller info] " <> toolName + + case toolName of + "query_database" -> do + let parseRegion = Aeson.withObject "input" (\o -> o Aeson..: "region") + case Aeson.Types.parseMaybe parseRegion toolInput of + Just region -> do + let result = queryDatabase region + Text.IO.putStrLn $ " Region: " <> region <> " -> " <> result + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just result + , Messages.is_error = Nothing + } + Nothing -> do + Text.IO.putStrLn " Error: missing region parameter" + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just "Error: missing region parameter" + , Messages.is_error = Just True + } + _ -> do + Text.IO.putStrLn $ " Unknown tool: " <> toolName + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just $ "Unknown tool: " <> toolName + , Messages.is_error = Just True + } + +-- | Print a content block summary +printContentBlock :: Messages.ContentBlock -> IO () +printContentBlock (Messages.ContentBlock_Text{ Messages.text = t }) = + Text.IO.putStrLn $ " [Text] " <> Text.take 80 t <> if Text.length t > 80 then "..." else "" +printContentBlock (Messages.ContentBlock_Tool_Use{ Messages.name = n, Messages.caller = c }) = + Text.IO.putStrLn $ " [Tool use] " <> n <> callerInfo c + where + callerInfo Nothing = "" + callerInfo (Just Messages.ToolCaller_Direct) = " (direct)" + callerInfo (Just Messages.ToolCaller_CodeExecution{}) = " (programmatic)" + callerInfo (Just Messages.ToolCaller_Unknown{}) = " (unknown caller)" +printContentBlock (Messages.ContentBlock_Server_Tool_Use{ Messages.name = n }) = + Text.IO.putStrLn $ " [Server tool use] " <> n +printContentBlock (Messages.ContentBlock_Tool_Search_Tool_Result{ Messages.tool_use_id = tid }) = + Text.IO.putStrLn $ " [Tool search result] " <> tid +printContentBlock (Messages.ContentBlock_Code_Execution_Tool_Result{ Messages.tool_use_id = tid, Messages.code_execution_content = c }) = do + Text.IO.putStrLn $ " [Code execution result] " <> tid + case c of + Messages.CodeExecutionResultContent result -> do + let Messages.CodeExecutionResult{ Messages.stdout = out, Messages.stderr = err, Messages.return_code = rc } = result + Text.IO.putStrLn $ " return_code: " <> Text.pack (show rc) + unless (Text.null out) $ + Text.IO.putStrLn $ " stdout: " <> Text.take 200 out <> if Text.length out > 200 then "..." else "" + unless (Text.null err) $ + Text.IO.putStrLn $ " stderr: " <> Text.take 200 err <> if Text.length err > 200 then "..." else "" + Messages.CodeExecutionToolResultContent_Unknown _ -> + Text.IO.putStrLn " (unknown content type)" + where + unless False action = action + unless True _ = pure () +printContentBlock (Messages.ContentBlock_Unknown{ Messages.type_ = t }) = + Text.IO.putStrLn $ " [Unknown] " <> t + +-- | Print final text content +printFinalContent :: Messages.ContentBlock -> IO () +printFinalContent (Messages.ContentBlock_Text{ Messages.text = t }) = Text.IO.putStrLn t +printFinalContent _ = pure () diff --git a/examples/claude-stream-example/Main.hs b/examples/claude-stream-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-stream-example/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import System.Environment (getEnv) +import System.IO (hFlush, hPutStrLn, stderr, stdout) + +import qualified Claude.V1 as V1 +import qualified Claude.V1.Messages as Messages +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +main :: IO () +main = do + key <- T.pack <$> getEnv "ANTHROPIC_KEY" + env <- V1.getClientEnv "https://api.anthropic.com" + + let V1.Methods{ createMessageStreamTyped } = V1.makeMethods env key (Just "2023-06-01") + + let onEvent (Left err) = hPutStrLn stderr ("stream error: " <> T.unpack err) + onEvent (Right ev) = case ev of + -- Print text deltas as they arrive + Messages.Content_Block_Delta{ Messages.delta = d } -> + case d of + Messages.Delta_Text_Delta{ Messages.text = t } -> + TIO.putStr t >> hFlush stdout + _ -> pure () + -- Print newline when message is done + Messages.Message_Stop -> putStrLn "" + -- Ignore other events + _ -> pure () + + -- Simple haiku test + let req = Messages._CreateMessage + { Messages.model = "claude-sonnet-4-5-20250929" + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Write a short haiku about the sea." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 200 + } + + createMessageStreamTyped req onEvent diff --git a/examples/claude-tool-example/Main.hs b/examples/claude-tool-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-tool-example/Main.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Example demonstrating tool use with Claude +-- +-- This example defines a simple "get_weather" tool and shows how to: +-- 1. Send a request with tools +-- 2. Handle tool_use responses +-- 3. Send tool results back to Claude +module Main where + +import Data.Aeson (FromJSON(..), Value, withObject, (.:), (.:?), (.=)) +import Data.Foldable (toList) +import Data.Text (Text) + +import qualified Claude.V1 as V1 +import qualified Claude.V1.Messages as Messages +import qualified Claude.V1.Tool as Tool +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Vector as Vector +import qualified System.Environment as Environment + +-- | Arguments for our weather tool +data WeatherArgs = WeatherArgs + { location :: Text + , unit :: Maybe Text + } deriving Show + +instance FromJSON WeatherArgs where + parseJSON = withObject "WeatherArgs" $ \obj -> do + loc <- obj .: "location" + u <- obj .:? "unit" + pure WeatherArgs{ location = loc, unit = u } + +-- | Fake weather function - in real use, this would call a weather API +getWeather :: Text -> Maybe Text -> Text +getWeather loc u = + "The weather in " <> loc <> " is 72°" <> tempUnit <> " and sunny." + where + tempUnit = case u of + Just "celsius" -> "C" + _ -> "F" + +-- | Define our weather tool +weatherTool :: Tool.Tool +weatherTool = Tool.Tool + { Tool.name = "get_weather" + , Tool.description = Just "Get the current weather for a location" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "location" .= Aeson.object + [ "type" .= ("string" :: Text) + , "description" .= ("City and state, e.g. San Francisco, CA" :: Text) + ] + , "unit" .= Aeson.object + [ "type" .= ("string" :: Text) + , "enum" .= (["celsius", "fahrenheit"] :: [Text]) + , "description" .= ("Temperature unit" :: Text) + ] + ] + , Tool.required = Just ["location"] + } + } + +main :: IO () +main = do + key <- Text.pack <$> Environment.getEnv "ANTHROPIC_KEY" + env <- V1.getClientEnv "https://api.anthropic.com" + + let V1.Methods{ V1.createMessage } = V1.makeMethods env key (Just "2023-06-01") + + -- Initial request asking about weather + let initialMessage = Messages.Message + { Messages.role = Messages.User + , Messages.content = [Messages.textContent "What's the weather like in San Francisco?"] + , Messages.cache_control = Nothing + } + + Text.IO.putStrLn "Sending initial request with weather tool..." + + firstResponse <- createMessage Messages._CreateMessage + { Messages.model = "claude-sonnet-4-5-20250929" + , Messages.messages = [initialMessage] + , Messages.max_tokens = 1024 + , Messages.tools = Just [Tool.inlineTool weatherTool] + } + + let Messages.MessageResponse{ Messages.stop_reason = stopReason, Messages.content = responseContent } = firstResponse + + Text.IO.putStrLn $ "Stop reason: " <> Text.pack (show stopReason) + + -- Check if Claude wants to use a tool + case stopReason of + Just Messages.Tool_Use -> do + Text.IO.putStrLn "Claude wants to use a tool!" + + -- Find the tool_use block(s) in the response + let toolUseBlocks = [ (toolId, toolName, toolInput) + | Messages.ContentBlock_Tool_Use{ Messages.id = toolId, Messages.name = toolName, Messages.input = toolInput, Messages.caller = _ } + <- toList responseContent + ] + + -- Process each tool call + toolResults <- mapM processToolCall toolUseBlocks + + Text.IO.putStrLn "Sending tool results back to Claude..." + + -- Send the tool results back + let assistantMessage = Messages.Message + { Messages.role = Messages.Assistant + , Messages.content = Vector.fromList + [ Messages.Content_Tool_Use{ Messages.id = tid, Messages.name = tname, Messages.input = tinput, Messages.caller = Nothing } + | (tid, tname, tinput) <- toolUseBlocks + ] + , Messages.cache_control = Nothing + } + + let userToolResults = Messages.Message + { Messages.role = Messages.User + , Messages.content = Vector.fromList toolResults + , Messages.cache_control = Nothing + } + + finalResponse <- createMessage Messages._CreateMessage + { Messages.model = "claude-sonnet-4-5-20250929" + , Messages.messages = [initialMessage, assistantMessage, userToolResults] + , Messages.max_tokens = 1024 + , Messages.tools = Just [Tool.inlineTool weatherTool] + } + + -- Print the final response + let Messages.MessageResponse{ Messages.content = finalContent } = finalResponse + Text.IO.putStrLn "\nClaude's final response:" + mapM_ printContent (toList finalContent) + + _ -> do + -- No tool use, just print the response + Text.IO.putStrLn "Claude responded directly:" + mapM_ printContent (toList responseContent) + +-- | Process a single tool call and return the result content +processToolCall :: (Text, Text, Value) -> IO Messages.Content +processToolCall (toolId, toolName, toolInput) = do + Text.IO.putStrLn $ "Processing tool call: " <> toolName + Text.IO.putStrLn $ "Input: " <> Text.Encoding.decodeUtf8 (LBS.toStrict (Aeson.encode toolInput)) + + case toolName of + "get_weather" -> do + case Aeson.fromJSON toolInput of + Aeson.Error err -> do + Text.IO.putStrLn $ "Error parsing args: " <> Text.pack err + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just $ "Error: " <> Text.pack err + , Messages.is_error = Just True + } + Aeson.Success WeatherArgs{ location = loc, unit = u } -> do + let result = getWeather loc u + Text.IO.putStrLn $ "Weather result: " <> result + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just result + , Messages.is_error = Nothing + } + _ -> do + Text.IO.putStrLn $ "Unknown tool: " <> toolName + pure Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just $ "Unknown tool: " <> toolName + , Messages.is_error = Just True + } + +-- | Print a content block +printContent :: Messages.ContentBlock -> IO () +printContent (Messages.ContentBlock_Text{ Messages.text = t }) = Text.IO.putStrLn t +printContent (Messages.ContentBlock_Tool_Use{ Messages.name = n }) = + Text.IO.putStrLn $ "[Tool use: " <> n <> "]" +printContent (Messages.ContentBlock_Server_Tool_Use{ Messages.name = n }) = + Text.IO.putStrLn $ "[Server tool use: " <> n <> "]" +printContent (Messages.ContentBlock_Tool_Search_Tool_Result{ Messages.tool_use_id = tid, Messages.tool_search_content = _ }) = + Text.IO.putStrLn $ "[Tool search result for: " <> tid <> "]" +printContent (Messages.ContentBlock_Code_Execution_Tool_Result{ Messages.tool_use_id = tid, Messages.code_execution_content = _ }) = + Text.IO.putStrLn $ "[Code execution result for: " <> tid <> "]" +printContent (Messages.ContentBlock_Unknown{ Messages.type_ = t }) = + Text.IO.putStrLn $ "[Unknown block type: " <> t <> "]" diff --git a/examples/claude-tool-search-example/Main.hs b/examples/claude-tool-search-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-tool-search-example/Main.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Example demonstrating tool search with Claude +-- +-- This example shows how to use the server-side tool search feature, +-- which allows Claude to efficiently search through large numbers of tools. +-- +-- Tool search requires the beta header: anthropic-beta: advanced-tool-use-2025-11-20 +module Main where + +import Data.Foldable (toList) +import Data.Text (Text) + +import qualified Claude.V1 as V1 +import qualified Claude.V1.Messages as Messages +import qualified Claude.V1.Tool as Tool +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified System.Environment as Environment + +-- | Define many tools to demonstrate tool search +-- In a real application, you might have hundreds of tools + +weatherTool :: Tool.Tool +weatherTool = Tool.Tool + { Tool.name = "get_weather" + , Tool.description = Just "Get the current weather for a location" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "location" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("City and state, e.g. San Francisco, CA" :: Text) + ] + ] + , Tool.required = Just ["location"] + } + } + +stockPriceTool :: Tool.Tool +stockPriceTool = Tool.Tool + { Tool.name = "get_stock_price" + , Tool.description = Just "Get the current stock price for a ticker symbol" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "ticker" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("Stock ticker symbol, e.g. AAPL" :: Text) + ] + ] + , Tool.required = Just ["ticker"] + } + } + +currencyConvertTool :: Tool.Tool +currencyConvertTool = Tool.Tool + { Tool.name = "convert_currency" + , Tool.description = Just "Convert an amount from one currency to another" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "amount" Aeson..= Aeson.object + [ "type" Aeson..= ("number" :: Text) + , "description" Aeson..= ("Amount to convert" :: Text) + ] + , "from_currency" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("Source currency code, e.g. USD" :: Text) + ] + , "to_currency" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("Target currency code, e.g. EUR" :: Text) + ] + ] + , Tool.required = Just ["amount", "from_currency", "to_currency"] + } + } + +calculatorTool :: Tool.Tool +calculatorTool = Tool.Tool + { Tool.name = "calculator" + , Tool.description = Just "Perform basic arithmetic calculations" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "expression" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("Math expression to evaluate, e.g. 2+2" :: Text) + ] + ] + , Tool.required = Just ["expression"] + } + } + +searchWebTool :: Tool.Tool +searchWebTool = Tool.Tool + { Tool.name = "search_web" + , Tool.description = Just "Search the web for information" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "query" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text) + , "description" Aeson..= ("Search query" :: Text) + ] + ] + , Tool.required = Just ["query"] + } + } + +main :: IO () +main = do + key <- Text.pack <$> Environment.getEnv "ANTHROPIC_KEY" + env <- V1.getClientEnv "https://api.anthropic.com" + + -- Use makeMethodsWith to include the beta header for tool search + let options = V1.defaultClientOptions + { V1.apiKey = key + , V1.anthropicBeta = Just "advanced-tool-use-2025-11-20" + } + let V1.Methods{ V1.createMessage } = V1.makeMethodsWith env options + + -- Set up tools with tool search enabled + -- The tool search tool is NOT deferred, while other tools are deferred + let tools = + [ Tool.toolSearchRegex -- Enable regex-based tool search + , Tool.deferredTool weatherTool + , Tool.deferredTool stockPriceTool + , Tool.deferredTool currencyConvertTool + , Tool.deferredTool calculatorTool + , Tool.deferredTool searchWebTool + ] + + let message = Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What's the weather like in Tokyo?" + ] + , Messages.cache_control = Nothing + } + + Text.IO.putStrLn "Sending request with tool search enabled..." + Text.IO.putStrLn $ "Using " <> Text.pack (show (length tools)) <> " tools (with deferred loading)" + + response <- createMessage Messages._CreateMessage + { Messages.model = "claude-sonnet-4-5-20250929" + , Messages.messages = [message] + , Messages.max_tokens = 1024 + , Messages.tools = Just tools + } + + let Messages.MessageResponse + { Messages.stop_reason = stopReason + , Messages.content = responseContent + , Messages.usage = Messages.Usage + { Messages.input_tokens = inputToks + , Messages.output_tokens = outputToks + , Messages.server_tool_use = serverToolUse + } + } = response + + Text.IO.putStrLn $ "\nStop reason: " <> Text.pack (show stopReason) + + -- Print usage info including tool search requests + Text.IO.putStrLn $ "Input tokens: " <> Text.pack (show inputToks) + Text.IO.putStrLn $ "Output tokens: " <> Text.pack (show outputToks) + case serverToolUse of + Just Messages.ServerToolUseUsage{ Messages.web_search_requests = webReqs, Messages.tool_search_requests = toolReqs } -> do + case webReqs of + Just n -> Text.IO.putStrLn $ "Web search requests: " <> Text.pack (show n) + Nothing -> pure () + case toolReqs of + Just n -> Text.IO.putStrLn $ "Tool search requests: " <> Text.pack (show n) + Nothing -> pure () + Nothing -> pure () + + Text.IO.putStrLn "\nResponse content:" + mapM_ printContent (toList responseContent) + +-- | Print a content block +printContent :: Messages.ContentBlock -> IO () +printContent (Messages.ContentBlock_Text{ Messages.text = t }) = + Text.IO.putStrLn $ " [text] " <> t +printContent (Messages.ContentBlock_Tool_Use{ Messages.name = n, Messages.id = tid }) = + Text.IO.putStrLn $ " [tool_use] " <> n <> " (id: " <> tid <> ")" +printContent (Messages.ContentBlock_Server_Tool_Use{ Messages.name = n, Messages.id = tid }) = + Text.IO.putStrLn $ " [server_tool_use] " <> n <> " (id: " <> tid <> ")" +printContent (Messages.ContentBlock_Tool_Search_Tool_Result{ Messages.tool_use_id = tid, Messages.tool_search_content = resultContent }) = do + Text.IO.putStrLn $ " [tool_search_result] for tool_use_id: " <> tid + case resultContent of + Messages.ToolSearchResult{ Messages.tool_references = refs } -> do + Text.IO.putStrLn $ " Found " <> Text.pack (show (length refs)) <> " matching tools:" + mapM_ (\Messages.ToolReference{ Messages.tool_name = tn } -> + Text.IO.putStrLn $ " - " <> tn) (toList refs) + Messages.ToolSearchError{ Messages.error_code = code } -> + Text.IO.putStrLn $ " Error: " <> code + Messages.ToolSearchResultContent_Unknown _ -> + Text.IO.putStrLn " Unknown result type" +printContent (Messages.ContentBlock_Code_Execution_Tool_Result{ Messages.tool_use_id = tid }) = + Text.IO.putStrLn $ " [code_execution_result] for tool_use_id: " <> tid +printContent (Messages.ContentBlock_Unknown{ Messages.type_ = t }) = + Text.IO.putStrLn $ " [unknown] type: " <> t diff --git a/examples/claude-vision-example/Main.hs b/examples/claude-vision-example/Main.hs new file mode 100644 --- /dev/null +++ b/examples/claude-vision-example/Main.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Example demonstrating vision capabilities with Claude +-- +-- This example shows how to send images to Claude for analysis. +-- Images can be sent as base64-encoded data. +module Main where + +import Claude.V1 +import Claude.V1.Messages +import Data.Foldable (traverse_) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified System.Environment as Environment + +main :: IO () +main = do + key <- Environment.getEnv "ANTHROPIC_KEY" + clientEnv <- getClientEnv "https://api.anthropic.com" + + let Methods{ createMessage } = makeMethods clientEnv (Text.pack key) (Just "2023-06-01") + + -- Read an image file and encode it as base64 + -- You can replace this path with any image you want to analyze + Text.IO.putStrLn "Reading image file..." + imageBytes <- BS.readFile "examples/claude-vision-example/test-image.png" + let base64Image = Text.Encoding.decodeUtf8 (Base64.encode imageBytes) + + Text.IO.putStrLn "Sending image to Claude for analysis..." + + -- Create message with image + MessageResponse{ content } <- createMessage _CreateMessage + { model = "claude-sonnet-4-5-20250929" + , messages = + [ Message + { role = User + , content = + [ Content_Image + { source = ImageSource + { type_ = "base64" + , media_type = "image/png" + , data_ = base64Image + } + , cache_control = Nothing + } + , textContent "What do you see in this image? Please describe it in detail." + ] + , cache_control = Nothing + } + ] + , max_tokens = 1024 + } + + Text.IO.putStrLn "\nClaude's response:" + let display (ContentBlock_Text{ text = t }) = Text.IO.putStrLn t + display _ = pure () + + traverse_ display content diff --git a/src/Claude/Prelude.hs b/src/Claude/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Prelude.hs @@ -0,0 +1,84 @@ +module Claude.Prelude + ( -- * JSON + aesonOptions + , stripPrefix + , labelModifier + -- * Re-exports + , module Data.Aeson + , module Data.ByteString.Lazy + , module Data.Map + , module Data.String + , module Data.Text + , module Data.Time.Clock.POSIX + , module Data.Vector + , module Data.Void + , module GHC.Generics + , module Numeric.Natural + , module Servant.API + , module Web.HttpApiData + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Vector (Vector) +import Data.Void (Void) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Web.HttpApiData (ToHttpApiData(..)) + +import Data.Aeson + ( FromJSON(..) + , Options(..) + , SumEncoding(..) + , ToJSON(..) + , Value(..) + , genericParseJSON + , genericToJSON + ) +import Servant.API + ( Accept(..) + , Capture + , Delete + , Get + , Header' + , JSON + , MimeUnrender(..) + , OctetStream + , Optional + , Post + , QueryParam + , ReqBody + , Required + , Strict + , (:<|>)(..) + , (:>) + ) + +import qualified Data.Aeson as Aeson +import qualified Data.Char as Char +import qualified Data.List as List + +dropTrailingUnderscore :: String -> String +dropTrailingUnderscore "_" = "" +dropTrailingUnderscore "" = "" +dropTrailingUnderscore (c : cs) = c : dropTrailingUnderscore cs + +labelModifier :: String -> String +labelModifier = map Char.toLower . dropTrailingUnderscore + +stripPrefix :: String -> String -> String +stripPrefix prefix string = labelModifier suffix + where + suffix = case List.stripPrefix prefix string of + Nothing -> string + Just x -> x + +aesonOptions :: Options +aesonOptions = Aeson.defaultOptions + { fieldLabelModifier = labelModifier + , constructorTagModifier = labelModifier + , omitNothingFields = True + } diff --git a/src/Claude/V1.hs b/src/Claude/V1.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1.hs @@ -0,0 +1,340 @@ +-- | @\/v1@ +-- +-- Example usage: +-- +-- @ +-- {-# LANGUAGE DuplicateRecordFields #-} +-- {-# LANGUAGE NamedFieldPuns #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE OverloadedLists #-} +-- +-- module Main where +-- +-- import "Data.Foldable" (`Data.Foldable.traverse_`) +-- import "Claude.V1" +-- import "Claude.V1.Messages" +-- +-- import qualified "Data.Text" as Text +-- import qualified "Data.Text.IO" as Text.IO +-- import qualified "System.Environment" as Environment +-- +-- main :: `IO` () +-- main = do +-- key <- Environment.`System.Environment.getEnv` \"ANTHROPIC_KEY\" +-- +-- clientEnv <- `Claude.V1.getClientEnv` \"https://api.anthropic.com\" +-- +-- let `Claude.V1.Methods`{ createMessage } = `Claude.V1.makeMethods` clientEnv (Text.`Data.Text.pack` key) (Just \"2023-06-01\") +-- +-- text <- Text.IO.`Data.Text.IO.getLine` +-- +-- `Claude.V1.Messages.MessageResponse`{ `Claude.V1.Messages.content` } <- createMessage `Claude.V1.Messages._CreateMessage` +-- { `Claude.V1.Messages.model` = \"claude-sonnet-4-20250514\" +-- , `Claude.V1.Messages.messages` = +-- [ `Claude.V1.Messages.Message` +-- { `Claude.V1.Messages.role` = `Claude.V1.Messages.User` +-- , `Claude.V1.Messages.content` = [ `Claude.V1.Messages.Content_Text`{ `Claude.V1.Messages.text` } ] +-- } +-- ] +-- , `Claude.V1.Messages.max_tokens` = 1024 +-- } +-- +-- let display (`Claude.V1.Messages.ContentBlock_Text`{ `Claude.V1.Messages.text` = t }) = Text.IO.`Data.Text.IO.putStrLn` t +-- display _ = pure () +-- +-- `Data.Foldable.traverse_` display content +-- @ + +module Claude.V1 + ( -- * Methods + Methods(..) + , getClientEnv + , makeMethods + , makeMethodsWith + , ClientOptions(..) + , defaultClientOptions + -- * Servant + , API + ) where + +import Claude.Prelude +import Claude.V1.Messages + ( CountTokensRequest + , CreateMessage + , MessageResponse + , MessageStreamEvent + , TokenCount + ) +import Claude.V1.Messages.Batches + (BatchObject, CreateBatch, ListBatchesResponse) +import Control.Monad (foldM) +import Data.ByteString.Char8 () +import Data.Proxy (Proxy(..)) +import Servant.Client (ClientEnv) + +import qualified Claude.V1.Messages as Messages +import qualified Claude.V1.Messages.Batches as Batches +import qualified Control.Exception as Exception +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Char8 as S8 +import qualified Data.IORef as IORef +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy.Builder.Int as Int +import qualified Network.HTTP.Client as HTTP.Client +import qualified Network.HTTP.Client.TLS as TLS +import qualified Network.HTTP.Types.Status as Status +import qualified Servant.Client as Client + +-- | Convenient utility to get a `ClientEnv` for the most common use case +getClientEnv + :: Text + -- ^ Base URL for API (e.g., "https://api.anthropic.com") + -> IO ClientEnv +getClientEnv baseUrlText = do + baseUrl <- Client.parseBaseUrl (Text.unpack baseUrlText) + + let managerSettings = TLS.tlsManagerSettings + { HTTP.Client.managerResponseTimeout = + HTTP.Client.responseTimeoutNone + } + + manager <- TLS.newTlsManagerWith managerSettings + + pure (Client.mkClientEnv manager baseUrl) + +-- | Client configuration options +data ClientOptions = ClientOptions + { apiKey :: Text + -- ^ API key for authentication + , anthropicVersion :: Maybe Text + -- ^ Anthropic-Version header (e.g., "2023-06-01") + , anthropicBeta :: Maybe Text + -- ^ Anthropic-Beta header for beta features (e.g., "advanced-tool-use-2025-11-20") + } deriving stock (Show) + +-- | Default client options (requires setting apiKey) +defaultClientOptions :: ClientOptions +defaultClientOptions = ClientOptions + { apiKey = "" + , anthropicVersion = Just "2023-06-01" + , anthropicBeta = Nothing + } + +-- | Get a record of API methods after providing an API key +-- +-- This is a convenience wrapper around 'makeMethodsWith' for common usage. +makeMethods + :: ClientEnv + -- ^ + -> Text + -- ^ API key + -> Maybe Text + -- ^ Anthropic-Version header (e.g., "2023-06-01") + -> Methods +makeMethods clientEnv key version = + makeMethodsWith clientEnv ClientOptions + { apiKey = key + , anthropicVersion = version + , anthropicBeta = Nothing + } + +-- | Get a record of API methods with full configuration options +-- +-- Use this when you need to pass beta headers (e.g., for tool search): +-- +-- @ +-- let options = defaultClientOptions +-- { apiKey = key +-- , anthropicBeta = Just "advanced-tool-use-2025-11-20" +-- } +-- let Methods{ createMessage } = makeMethodsWith clientEnv options +-- @ +makeMethodsWith + :: ClientEnv + -> ClientOptions + -> Methods +makeMethodsWith clientEnv ClientOptions{ apiKey, anthropicVersion, anthropicBeta } = Methods{..} + where + ((createMessage_ :<|> countTokens_) :<|> (createBatch_ :<|> retrieveBatch_ :<|> listBatches_ :<|> cancelBatch_)) = + Client.hoistClient @API Proxy run (Client.client @API Proxy) apiKey anthropicVersion anthropicBeta + + run :: Client.ClientM a -> IO a + run clientM = do + result <- Client.runClientM clientM clientEnv + case result of + Left exception -> Exception.throwIO exception + Right a -> return a + + createMessage = createMessage_ + countTokens = countTokens_ + createBatch = createBatch_ + retrieveBatch = retrieveBatch_ + listBatches = listBatches_ + cancelBatch = cancelBatch_ + + -- Streaming implementation using http-client and SSE parsing + createMessageStream req onEvent = do + let req' = req{ Messages.stream = Just True } + ssePostJSON "/v1/messages" req' onEvent + + createMessageStreamTyped + :: CreateMessage + -> (Either Text MessageStreamEvent -> IO ()) + -> IO () + createMessageStreamTyped req onEvent = + createMessageStream req $ \ev -> case ev of + Left err -> onEvent (Left err) + Right val -> case Aeson.fromJSON val of + Aeson.Error msg -> onEvent (Left (Text.pack msg)) + Aeson.Success e -> onEvent (Right e) + + ssePostJSON :: ToJSON a + => String + -> a + -> (Either Text Aeson.Value -> IO ()) + -> IO () + ssePostJSON path body onEvent = do + let base = Client.baseUrl clientEnv + let secure = case Client.baseUrlScheme base of + Client.Http -> False + Client.Https -> True + let host = S8.pack (Client.baseUrlHost base) + let port = Client.baseUrlPort base + let basePath = Client.baseUrlPath base + let fullPath = S8.pack (normalizePath basePath <> path) + + let headers0 = + [ ("x-api-key", S8.pack (Text.unpack apiKey)) + , ("Accept", "text/event-stream") + , ("Content-Type", "application/json") + ] + let headers1 = case anthropicVersion of + Nothing -> headers0 + Just v -> ("anthropic-version", S8.pack (Text.unpack v)) : headers0 + let headers = case anthropicBeta of + Nothing -> headers1 + Just b -> ("anthropic-beta", S8.pack (Text.unpack b)) : headers1 + + let request = HTTP.Client.defaultRequest + { HTTP.Client.secure = secure + , HTTP.Client.host = host + , HTTP.Client.port = port + , HTTP.Client.method = "POST" + , HTTP.Client.path = fullPath + , HTTP.Client.requestHeaders = headers + , HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS (Aeson.encode body) + , HTTP.Client.responseTimeout = HTTP.Client.responseTimeoutNone + } + + HTTP.Client.withResponse request (Client.manager clientEnv) $ \response -> do + -- Short-circuit on non-2xx HTTP statuses and surface a single error event + let st = HTTP.Client.responseStatus response + if not (Status.statusIsSuccessful st) + then do + bodyChunks <- HTTP.Client.brConsume (HTTP.Client.responseBody response) + let errBody = SBS.concat bodyChunks + let msg = + "HTTP error " + <> renderIntegral (Status.statusCode st) + <> " " + <> (Text.pack (S8.unpack (Status.statusMessage st))) + <> (if SBS.null errBody then "" else ": " <> Text.pack (S8.unpack errBody)) + onEvent (Left msg) + else do + let br = HTTP.Client.responseBody response + lineBufRef <- IORef.newIORef SBS.empty + eventBufRef <- IORef.newIORef ([] :: [SBS.ByteString]) + let flushEvent = do + es <- IORef.atomicModifyIORef eventBufRef (\buf -> ([], reverse buf)) + if null es + then pure False + else do + let payload = S8.concat es + -- Claude uses "event: message_stop" as the final event, not [DONE] + case (Aeson.eitherDecodeStrict payload :: Either String Aeson.Value) of + Left err -> onEvent (Left (Text.pack err)) >> pure False + Right val -> onEvent (Right val) >> pure False + + -- Note: SSE frames can include fields like "event:" and others. + -- We currently only buffer "data:" lines; an empty line flushes a complete event. + let handleLine line = do + let l = stripCR line + 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 + + let loop = do + chunk <- HTTP.Client.brRead br + if SBS.null chunk + then do + -- flush any pending event at EOF + _ <- flushEvent + pure () + else do + prev <- IORef.readIORef lineBufRef + let combined = prev <> chunk + let 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 p = case p of + "" -> "" + ('/':_) -> p + _ -> '/':p + + stripCR bs = case S8.unsnoc bs of + Just (initBs, '\r') -> initBs + _ -> bs + + unsnoc [] = Nothing + unsnoc xs = Just (init xs, last xs) + + renderIntegral :: Integral number => number -> Text + renderIntegral number = Text.Lazy.toStrict (Builder.toLazyText builder) + where + builder = Int.decimal number + +-- | API methods +data Methods = Methods + { createMessage :: CreateMessage -> IO MessageResponse + , createMessageStream + :: CreateMessage + -> (Either Text Aeson.Value -> IO ()) + -> IO () + , createMessageStreamTyped + :: CreateMessage + -> (Either Text MessageStreamEvent -> IO ()) + -> IO () + , countTokens :: CountTokensRequest -> IO TokenCount + -- Batch methods + , createBatch :: CreateBatch -> IO BatchObject + , retrieveBatch :: Text -> IO BatchObject + , listBatches + :: Maybe Natural -- ^ limit + -> Maybe Text -- ^ before_id + -> Maybe Text -- ^ after_id + -> IO ListBatchesResponse + , cancelBatch :: Text -> IO BatchObject + } + +-- | Servant API +type API + = Header' [ Required, Strict ] "x-api-key" Text + :> Header' [ Optional, Strict ] "anthropic-version" Text + :> Header' [ Optional, Strict ] "anthropic-beta" Text + :> "v1" + :> (Messages.API :<|> Batches.API) diff --git a/src/Claude/V1/Error.hs b/src/Claude/V1/Error.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1/Error.hs @@ -0,0 +1,41 @@ +-- | Error types for Claude API +module Claude.V1.Error + ( -- * Types + Error(..) + , ErrorType(..) + ) where + +import Claude.Prelude + +-- | The type of error that occurred +data ErrorType + = Invalid_Request_Error + | Authentication_Error + | Permission_Error + | Not_Found_Error + | Rate_Limit_Error + | Api_Error + | Overloaded_Error + deriving stock (Eq, Generic, Show) + +errorTypeOptions :: Options +errorTypeOptions = aesonOptions + { constructorTagModifier = stripPrefix "" } + +instance FromJSON ErrorType where + parseJSON = genericParseJSON errorTypeOptions + +instance ToJSON ErrorType where + toJSON = genericToJSON errorTypeOptions + +-- | Error information returned by the Claude API +data Error = Error + { type_ :: ErrorType + , message :: Text + } deriving stock (Generic, Show) + +instance FromJSON Error where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Error where + toJSON = genericToJSON aesonOptions diff --git a/src/Claude/V1/Messages.hs b/src/Claude/V1/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1/Messages.hs @@ -0,0 +1,758 @@ +-- | @\/v1\/messages@ +-- +-- This module provides types and utilities for the Claude Messages API. +module Claude.V1.Messages + ( -- * Main types + CreateMessage(..) + , _CreateMessage + , MessageResponse(..) + , MessageStreamEvent(..) + -- * Content types + , Content(..) + , ContentBlock(..) + , TextContent(..) + , ImageSource(..) + , ToolUseContent(..) + , ToolResultContent(..) + -- * Message types + , Message(..) + , Role(..) + -- * Response types + , StopReason(..) + , Usage(..) + , ServerToolUseUsage(..) + -- * Tool search response types + , ToolReference(..) + , ToolSearchToolResultContent(..) + -- * Programmatic tool calling (PTC) types + , ContainerInfo(..) + , ToolCaller(..) + , CodeExecutionResult(..) + , CodeExecutionToolResultContent(..) + , contentBlockToContent + -- * Tool types (re-exported from Claude.V1.Tool) + , Tool(..) + , ToolChoice(..) + , InputSchema(..) + , ToolDefinition(..) + , ToolSearchTool(..) + , ToolSearchToolType(..) + , functionTool + , inlineTool + , deferredTool + , toolSearchRegex + , toolSearchBm25 + , codeExecutionTool + , allowedCallersCodeExecution + , allowCallers + , toolChoiceAuto + , toolChoiceAny + , toolChoiceTool + -- * Streaming types + , ContentBlockDelta(..) + , TextDelta(..) + , InputJsonDelta(..) + , MessageDelta(..) + , StreamUsage(..) + -- * Token counting + , CountTokensRequest(..) + , _CountTokensRequest + , TokenCount(..) + -- * Prompt caching + , CacheControl(..) + , ephemeralCache + -- * Convenience constructors + , textContent + , imageContent + -- * Servant + , API + , MessagesAPI + , CountTokensAPI + ) where + +import Claude.Prelude +import Claude.V1.Tool + ( InputSchema(..) + , Tool(..) + , ToolChoice(..) + , ToolDefinition(..) + , ToolSearchTool(..) + , ToolSearchToolType(..) + , allowCallers + , allowedCallersCodeExecution + , codeExecutionTool + , deferredTool + , functionTool + , inlineTool + , toolChoiceAny + , toolChoiceAuto + , toolChoiceTool + , toolSearchBm25 + , toolSearchRegex + ) +import Data.Time (UTCTime) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap + +-- | Role of a message participant +data Role = User | Assistant + deriving stock (Eq, Generic, Show) + +instance FromJSON Role where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Role where + toJSON = genericToJSON aesonOptions + +-- | Image source for vision capabilities +data ImageSource = ImageSource + { type_ :: Text -- ^ "base64" + , media_type :: Text -- ^ "image/jpeg", "image/png", etc. + , data_ :: Text -- ^ Base64 encoded image data + } deriving stock (Generic, Show) + +instance FromJSON ImageSource where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ImageSource where + toJSON = genericToJSON aesonOptions + +-- | Cache control for prompt caching +data CacheControl = CacheControl + { type_ :: Text -- ^ Currently only "ephemeral" is supported + } deriving stock (Generic, Show) + +instance FromJSON CacheControl where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CacheControl where + toJSON = genericToJSON aesonOptions + +-- | Convenience constructor for ephemeral cache control +ephemeralCache :: CacheControl +ephemeralCache = CacheControl{ type_ = "ephemeral" } + +-- | Text content block +data TextContent = TextContent + { text :: Text + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Tool use content block (in assistant messages) +data ToolUseContent = ToolUseContent + { id :: Text + , name :: Text + , input :: Value + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Tool result content (in user messages, following tool use) +data ToolResultContent = ToolResultContent + { tool_use_id :: Text + , content :: Maybe Text + , is_error :: Maybe Bool + } deriving stock (Generic, Show) + +instance FromJSON ToolResultContent where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ToolResultContent where + toJSON = genericToJSON aesonOptions + +-- | Content block in a message (for requests) +-- +-- For programmatic tool calling (PTC), replay assistant messages using: +-- +-- * 'Content_Tool_Use' with optional @caller@ field +-- * 'Content_Server_Tool_Use' for code execution invocations +data Content + = Content_Text + { text :: Text + , cache_control :: Maybe CacheControl + } + | Content_Image + { source :: ImageSource + , cache_control :: Maybe CacheControl + } + | Content_Tool_Use + { id :: Text + , name :: Text + , input :: Value + , caller :: Maybe ToolCaller + } + | Content_Server_Tool_Use + { id :: Text + , name :: Text + , input :: Value + } + | Content_Tool_Result { tool_use_id :: Text, content :: Maybe Text, is_error :: Maybe Bool } + deriving stock (Generic, Show) + +-- | Create a text content block without cache control +textContent :: Text -> Content +textContent t = Content_Text{ text = t, cache_control = Nothing } + +-- | Create an image content block without cache control +imageContent :: ImageSource -> Content +imageContent src = Content_Image{ source = src, cache_control = Nothing } + +contentOptions :: Options +contentOptions = aesonOptions + { sumEncoding = TaggedObject{ tagFieldName = "type", contentsFieldName = "" } + , tagSingleConstructors = True + , constructorTagModifier = stripPrefix "Content_" + } + +instance FromJSON Content where + parseJSON = genericParseJSON contentOptions + +instance ToJSON Content where + toJSON = genericToJSON contentOptions + +-- | Convert a response 'ContentBlock' to a request 'Content' for replaying +-- +-- This is useful for programmatic tool calling (PTC) where you need to +-- replay assistant messages in subsequent requests. +-- +-- Returns 'Nothing' for content blocks that don't need to be replayed: +-- +-- * 'ContentBlock_Tool_Search_Tool_Result' +-- * 'ContentBlock_Code_Execution_Tool_Result' +-- * 'ContentBlock_Unknown' +contentBlockToContent :: ContentBlock -> Maybe Content +contentBlockToContent (ContentBlock_Text t) = + Just Content_Text{ text = t, cache_control = Nothing } +contentBlockToContent (ContentBlock_Tool_Use toolId toolName toolInput toolCaller) = + Just Content_Tool_Use + { id = toolId + , name = toolName + , input = toolInput + , caller = toolCaller + } +contentBlockToContent (ContentBlock_Server_Tool_Use toolId toolName toolInput) = + Just Content_Server_Tool_Use + { id = toolId + , name = toolName + , input = toolInput + } +contentBlockToContent ContentBlock_Tool_Search_Tool_Result{} = Nothing +contentBlockToContent ContentBlock_Code_Execution_Tool_Result{} = Nothing +contentBlockToContent ContentBlock_Unknown{} = Nothing + +-- | A reference to a tool found by tool search +data ToolReference = ToolReference + { tool_name :: Text + } deriving stock (Eq, Generic, Show) + +instance FromJSON ToolReference where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ToolReference where + toJSON = genericToJSON aesonOptions + +-- | Content of a tool search tool result +-- +-- This can be either successful search results with tool references, +-- an error, or an unknown type for forward compatibility. +data ToolSearchToolResultContent + = ToolSearchResult + { tool_references :: Vector ToolReference + } + | ToolSearchError + { error_code :: Text + } + | ToolSearchResultContent_Unknown Value + deriving stock (Eq, Show) + +instance FromJSON ToolSearchToolResultContent where + parseJSON = Aeson.withObject "ToolSearchToolResultContent" $ \o -> do + t <- o Aeson..: "type" + case (t :: Text) of + "tool_search_result" -> do + tool_references <- o Aeson..: "tool_references" + pure ToolSearchResult{ tool_references } + "error" -> do + error_code <- o Aeson..: "error_code" + pure ToolSearchError{ error_code } + _ -> pure (ToolSearchResultContent_Unknown (Aeson.Object o)) + +instance ToJSON ToolSearchToolResultContent where + toJSON (ToolSearchResult refs) = Aeson.object + [ "type" Aeson..= ("tool_search_result" :: Text) + , "tool_references" Aeson..= refs + ] + toJSON (ToolSearchError code) = Aeson.object + [ "type" Aeson..= ("error" :: Text) + , "error_code" Aeson..= code + ] + toJSON (ToolSearchResultContent_Unknown v) = v + +-- | Container information for programmatic tool calling (PTC) +-- +-- When using code execution, Claude runs code in a container. The container +-- can be reused across multiple turns by passing its @id@ in subsequent requests. +data ContainerInfo = ContainerInfo + { id :: Text + , expires_at :: UTCTime + } deriving stock (Eq, Generic, Show) + +instance FromJSON ContainerInfo where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ContainerInfo where + toJSON = genericToJSON aesonOptions + +-- | Identifies who called a tool (for programmatic tool calling) +-- +-- * 'ToolCaller_Direct': Claude called the tool directly +-- * 'ToolCaller_CodeExecution': Code execution called the tool programmatically +-- * 'ToolCaller_Unknown': Unknown caller type (forward compatibility) +data ToolCaller + = ToolCaller_Direct + | ToolCaller_CodeExecution { tool_id :: Text } + | ToolCaller_Unknown Value + deriving stock (Eq, Show) + +instance FromJSON ToolCaller where + parseJSON = Aeson.withObject "ToolCaller" $ \o -> do + t <- o Aeson..: "type" + case (t :: Text) of + "direct" -> pure ToolCaller_Direct + "code_execution_20250825" -> do + tool_id <- o Aeson..: "tool_id" + pure ToolCaller_CodeExecution{ tool_id } + _ -> pure (ToolCaller_Unknown (Aeson.Object o)) + +instance ToJSON ToolCaller where + toJSON ToolCaller_Direct = Aeson.object + [ "type" Aeson..= ("direct" :: Text) + ] + toJSON (ToolCaller_CodeExecution tid) = Aeson.object + [ "type" Aeson..= ("code_execution_20250825" :: Text) + , "tool_id" Aeson..= tid + ] + toJSON (ToolCaller_Unknown v) = v + +-- | Result from code execution +-- +-- Contains stdout, stderr, return code, and any additional content +-- (e.g., generated files, images). +data CodeExecutionResult = CodeExecutionResult + { stdout :: Text + , stderr :: Text + , return_code :: Int + , content :: Vector Value + } deriving stock (Eq, Generic, Show) + +instance FromJSON CodeExecutionResult where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CodeExecutionResult where + toJSON = genericToJSON aesonOptions + +-- | Content of a code execution tool result +-- +-- * 'CodeExecutionResultContent': Successful execution with stdout/stderr +-- * 'CodeExecutionToolResultContent_Unknown': Unknown content type (forward compatibility) +data CodeExecutionToolResultContent + = CodeExecutionResultContent CodeExecutionResult + | CodeExecutionToolResultContent_Unknown Value + deriving stock (Eq, Show) + +instance FromJSON CodeExecutionToolResultContent where + parseJSON = Aeson.withObject "CodeExecutionToolResultContent" $ \o -> do + t <- o Aeson..: "type" + case (t :: Text) of + "code_execution_result" -> do + result <- Aeson.parseJSON (Aeson.Object o) + pure (CodeExecutionResultContent result) + _ -> pure (CodeExecutionToolResultContent_Unknown (Aeson.Object o)) + +instance ToJSON CodeExecutionToolResultContent where + toJSON (CodeExecutionResultContent result) = + case Aeson.toJSON result of + Aeson.Object o -> Aeson.Object (KeyMap.insert "type" (Aeson.String "code_execution_result") o) + v -> v + toJSON (CodeExecutionToolResultContent_Unknown v) = v + +-- | Content block in a response +-- +-- Extended to support: +-- +-- * @server_tool_use@: Server-initiated tool use (e.g., tool search, code execution) +-- * @tool_search_tool_result@: Results from server-side tool search +-- * @code_execution_tool_result@: Results from code execution (PTC) +-- +-- For programmatic tool calling, 'ContentBlock_Tool_Use' includes an optional +-- @caller@ field indicating whether the tool was called directly by Claude +-- or programmatically by code execution. +data ContentBlock + = ContentBlock_Text { text :: Text } + | ContentBlock_Tool_Use + { id :: Text + , name :: Text + , input :: Value + , caller :: Maybe ToolCaller + } + | ContentBlock_Server_Tool_Use { id :: Text, name :: Text, input :: Value } + | ContentBlock_Tool_Search_Tool_Result + { tool_use_id :: Text + , tool_search_content :: ToolSearchToolResultContent + } + | ContentBlock_Code_Execution_Tool_Result + { tool_use_id :: Text + , code_execution_content :: CodeExecutionToolResultContent + } + | ContentBlock_Unknown { type_ :: Text, raw :: Value } + deriving stock (Generic, Show) + +instance FromJSON ContentBlock where + parseJSON = Aeson.withObject "ContentBlock" $ \o -> do + t <- o Aeson..: "type" + case (t :: Text) of + "text" -> ContentBlock_Text <$> o Aeson..: "text" + "tool_use" -> ContentBlock_Tool_Use + <$> o Aeson..: "id" + <*> o Aeson..: "name" + <*> o Aeson..: "input" + <*> o Aeson..:? "caller" + "server_tool_use" -> ContentBlock_Server_Tool_Use + <$> o Aeson..: "id" + <*> o Aeson..: "name" + <*> o Aeson..: "input" + "tool_search_tool_result" -> do + toolUseId <- o Aeson..: "tool_use_id" + searchContent <- o Aeson..: "content" + pure ContentBlock_Tool_Search_Tool_Result + { tool_use_id = toolUseId + , tool_search_content = searchContent + } + "code_execution_tool_result" -> do + toolUseId <- o Aeson..: "tool_use_id" + execContent <- o Aeson..: "content" + pure ContentBlock_Code_Execution_Tool_Result + { tool_use_id = toolUseId + , code_execution_content = execContent + } + _ -> pure (ContentBlock_Unknown t (Aeson.Object o)) + +instance ToJSON ContentBlock where + toJSON (ContentBlock_Text t) = Aeson.object + [ "type" Aeson..= ("text" :: Text) + , "text" Aeson..= t + ] + toJSON (ContentBlock_Tool_Use toolId toolName toolInput toolCaller) = Aeson.object $ + [ "type" Aeson..= ("tool_use" :: Text) + , "id" Aeson..= toolId + , "name" Aeson..= toolName + , "input" Aeson..= toolInput + ] <> maybe [] (\c -> ["caller" Aeson..= c]) toolCaller + toJSON (ContentBlock_Server_Tool_Use toolId toolName toolInput) = Aeson.object + [ "type" Aeson..= ("server_tool_use" :: Text) + , "id" Aeson..= toolId + , "name" Aeson..= toolName + , "input" Aeson..= toolInput + ] + toJSON (ContentBlock_Tool_Search_Tool_Result toolUseId searchContent) = Aeson.object + [ "type" Aeson..= ("tool_search_tool_result" :: Text) + , "tool_use_id" Aeson..= toolUseId + , "content" Aeson..= searchContent + ] + toJSON (ContentBlock_Code_Execution_Tool_Result toolUseId execContent) = Aeson.object + [ "type" Aeson..= ("code_execution_tool_result" :: Text) + , "tool_use_id" Aeson..= toolUseId + , "content" Aeson..= execContent + ] + toJSON (ContentBlock_Unknown _typeName rawVal) = rawVal + +-- | A message in the conversation +-- +-- The optional @cache_control@ field allows setting cache breakpoints at +-- the message level (in addition to content-level caching). +data Message = Message + { role :: Role + , content :: Vector Content + , cache_control :: Maybe CacheControl + } deriving stock (Generic, Show) + +instance FromJSON Message where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Message where + toJSON = genericToJSON aesonOptions + +-- | Reason why the model stopped generating +data StopReason + = End_Turn + | Max_Tokens + | Stop_Sequence + | Tool_Use + deriving stock (Eq, Generic, Show) + +stopReasonOptions :: Options +stopReasonOptions = aesonOptions + { constructorTagModifier = stripPrefix "" } + +instance FromJSON StopReason where + parseJSON = genericParseJSON stopReasonOptions + +instance ToJSON StopReason where + toJSON = genericToJSON stopReasonOptions + +-- | Server tool use usage information (e.g., tool search requests, web search requests) +data ServerToolUseUsage = ServerToolUseUsage + { web_search_requests :: Maybe Natural + , tool_search_requests :: Maybe Natural + } deriving stock (Eq, Generic, Show) + +instance FromJSON ServerToolUseUsage where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ServerToolUseUsage where + toJSON = genericToJSON aesonOptions + +-- | Token usage information +data Usage = Usage + { input_tokens :: Natural + , output_tokens :: Natural + , cache_creation_input_tokens :: Maybe Natural + , cache_read_input_tokens :: Maybe Natural + , server_tool_use :: Maybe ServerToolUseUsage + } deriving stock (Generic, Show) + +instance FromJSON Usage where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Usage where + toJSON = genericToJSON aesonOptions + +-- | Response from the Messages API +-- +-- For programmatic tool calling (PTC), the @container@ field contains +-- information about the code execution container, which can be reused +-- across turns by passing its @id@ in subsequent requests. +data MessageResponse = MessageResponse + { id :: Text + , type_ :: Text + , role :: Role + , content :: Vector ContentBlock + , model :: Text + , stop_reason :: Maybe StopReason + , stop_sequence :: Maybe Text + , usage :: Usage + , container :: Maybe ContainerInfo + } deriving stock (Generic, Show) + +instance FromJSON MessageResponse where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON MessageResponse where + toJSON = genericToJSON aesonOptions + +-- | Request body for @\/v1\/messages@ +-- +-- For programmatic tool calling (PTC), use the @container@ field to reuse +-- a code execution container from a previous response. +data CreateMessage = CreateMessage + { model :: Text + , messages :: Vector Message + , max_tokens :: Natural + , system :: Maybe Text + , temperature :: Maybe Double + , top_p :: Maybe Double + , top_k :: Maybe Natural + , stop_sequences :: Maybe (Vector Text) + , stream :: Maybe Bool + , metadata :: Maybe (Map Text Text) + , tools :: Maybe (Vector ToolDefinition) + , tool_choice :: Maybe ToolChoice + , container :: Maybe Text + } deriving stock (Generic, Show) + +instance FromJSON CreateMessage where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CreateMessage where + toJSON = genericToJSON aesonOptions + +-- | Default CreateMessage with only required fields +_CreateMessage :: CreateMessage +_CreateMessage = CreateMessage + { model = "" + , messages = mempty + , max_tokens = 1024 + , system = Nothing + , temperature = Nothing + , top_p = Nothing + , top_k = Nothing + , stop_sequences = Nothing + , stream = Nothing + , metadata = Nothing + , tools = Nothing + , tool_choice = Nothing + , container = Nothing + } + +-- | Text delta in streaming +data TextDelta = TextDelta + { text :: Text + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Input JSON delta in streaming (for tool use) +data InputJsonDelta = InputJsonDelta + { partial_json :: Text + } deriving stock (Generic, Show) + +instance FromJSON InputJsonDelta where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON InputJsonDelta where + toJSON = genericToJSON aesonOptions + +-- | Content block delta in streaming +data ContentBlockDelta + = Delta_Text_Delta { text :: Text } + | Delta_Input_Json_Delta { partial_json :: Text } + deriving stock (Generic, Show) + +contentBlockDeltaOptions :: Options +contentBlockDeltaOptions = aesonOptions + { sumEncoding = TaggedObject{ tagFieldName = "type", contentsFieldName = "" } + , tagSingleConstructors = True + , constructorTagModifier = \s -> case s of + "Delta_Text_Delta" -> "text_delta" + "Delta_Input_Json_Delta" -> "input_json_delta" + _ -> s + } + +instance FromJSON ContentBlockDelta where + parseJSON = genericParseJSON contentBlockDeltaOptions + +instance ToJSON ContentBlockDelta where + toJSON = genericToJSON contentBlockDeltaOptions + +-- | Message delta in streaming (for stop_reason, etc.) +data MessageDelta = MessageDelta + { stop_reason :: Maybe StopReason + , stop_sequence :: Maybe Text + } deriving stock (Generic, Show) + +instance FromJSON MessageDelta where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON MessageDelta where + toJSON = genericToJSON aesonOptions + +-- | Usage in streaming message_delta events +data StreamUsage = StreamUsage + { output_tokens :: Natural + } deriving stock (Generic, Show) + +instance FromJSON StreamUsage where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON StreamUsage where + toJSON = genericToJSON aesonOptions + +-- | Streaming events for @\/v1\/messages@ +data MessageStreamEvent + = Message_Start + { message :: MessageResponse + } + | Content_Block_Start + { index :: Natural + , content_block :: ContentBlock + } + | Content_Block_Delta + { index :: Natural + , delta :: ContentBlockDelta + } + | Content_Block_Stop + { index :: Natural + } + | Message_Delta + { message_delta :: MessageDelta + , usage :: StreamUsage + } + | Message_Stop + | Ping + | Error + { error :: Value + } + deriving stock (Generic, Show) + +messageStreamEventOptions :: Options +messageStreamEventOptions = aesonOptions + { sumEncoding = TaggedObject{ tagFieldName = "type", contentsFieldName = "" } + , tagSingleConstructors = True + , constructorTagModifier = \s -> case s of + "Message_Start" -> "message_start" + "Content_Block_Start" -> "content_block_start" + "Content_Block_Delta" -> "content_block_delta" + "Content_Block_Stop" -> "content_block_stop" + "Message_Delta" -> "message_delta" + "Message_Stop" -> "message_stop" + "Ping" -> "ping" + "Error" -> "error" + _ -> s + , fieldLabelModifier = \s -> case s of + "message_delta" -> "delta" + other -> labelModifier other + } + +instance FromJSON MessageStreamEvent where + parseJSON = genericParseJSON messageStreamEventOptions + +instance ToJSON MessageStreamEvent where + toJSON = genericToJSON messageStreamEventOptions + +-- | Request body for @\/v1\/messages\/count_tokens@ +-- +-- Note: This differs from CreateMessage - it doesn't include max_tokens +-- and other generation parameters. +data CountTokensRequest = CountTokensRequest + { model :: Text + , messages :: Vector Message + , system :: Maybe Text + , tools :: Maybe (Vector ToolDefinition) + , tool_choice :: Maybe ToolChoice + } deriving stock (Generic, Show) + +instance FromJSON CountTokensRequest where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CountTokensRequest where + toJSON = genericToJSON aesonOptions + +-- | Default CountTokensRequest +_CountTokensRequest :: CountTokensRequest +_CountTokensRequest = CountTokensRequest + { model = "" + , messages = mempty + , system = Nothing + , tools = Nothing + , tool_choice = Nothing + } + +-- | Response from the token counting endpoint +data TokenCount = TokenCount + { input_tokens :: Natural + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Servant API for @\/v1\/messages@ +type MessagesAPI = + ReqBody '[JSON] CreateMessage + :> Post '[JSON] MessageResponse + +-- | Servant API for @\/v1\/messages\/count_tokens@ +type CountTokensAPI = + "count_tokens" + :> ReqBody '[JSON] CountTokensRequest + :> Post '[JSON] TokenCount + +-- | Combined Servant API +type API = + "messages" + :> (MessagesAPI :<|> CountTokensAPI) diff --git a/src/Claude/V1/Messages/Batches.hs b/src/Claude/V1/Messages/Batches.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1/Messages/Batches.hs @@ -0,0 +1,151 @@ +-- | @\/v1\/messages\/batches@ +-- +-- This module provides types for the Claude Message Batches API. +-- Batches allow asynchronous processing of multiple messages at once. +module Claude.V1.Messages.Batches + ( -- * Request types + CreateBatch(..) + , _CreateBatch + , BatchRequest(..) + -- * Response types + , BatchObject(..) + , ProcessingStatus(..) + , RequestCounts(..) + , BatchResult(..) + , BatchResultType(..) + , ListBatchesResponse(..) + -- * Servant + , API + ) where + +import Claude.Prelude +import Claude.V1.Messages (CreateMessage, MessageResponse) + +import qualified Data.Aeson as Aeson +import qualified Data.Char as Char +import qualified Claude.V1.Error as Error + +-- | A single request within a batch +data BatchRequest = BatchRequest + { custom_id :: Text -- ^ Developer-provided ID for matching results + , params :: CreateMessage -- ^ The message request parameters + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Request body for creating a batch +data CreateBatch = CreateBatch + { requests :: Vector BatchRequest + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Default CreateBatch +_CreateBatch :: CreateBatch +_CreateBatch = CreateBatch + { requests = mempty + } + +-- | Processing status of a batch +data ProcessingStatus + = In_Progress + | Canceling + | Ended + deriving stock (Eq, Generic, Show) + +processingStatusOptions :: Options +processingStatusOptions = Aeson.defaultOptions + { constructorTagModifier = map Char.toLower + } + +instance FromJSON ProcessingStatus where + parseJSON = genericParseJSON processingStatusOptions + +instance ToJSON ProcessingStatus where + toJSON = genericToJSON processingStatusOptions + +-- | Counts of requests in various states +data RequestCounts = RequestCounts + { processing :: Natural + , succeeded :: Natural + , errored :: Natural + , canceled :: Natural + , expired :: Natural + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A batch object returned from the API +data BatchObject = BatchObject + { id :: Text + , type_ :: Text -- ^ Always "message_batch" + , processing_status :: ProcessingStatus + , request_counts :: RequestCounts + , ended_at :: Maybe POSIXTime + , created_at :: POSIXTime + , expires_at :: POSIXTime + , cancel_initiated_at :: Maybe POSIXTime + , results_url :: Maybe Text + } deriving stock (Generic, Show) + +instance FromJSON BatchObject where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON BatchObject where + toJSON = genericToJSON aesonOptions + +-- | Type of result for a batch request +data BatchResultType + = Succeeded { message :: MessageResponse } + | Errored { error :: Error.Error } + | Canceled + | Expired + deriving stock (Generic, Show) + +batchResultTypeOptions :: Options +batchResultTypeOptions = Aeson.defaultOptions + { sumEncoding = TaggedObject{ tagFieldName = "type", contentsFieldName = "" } + , tagSingleConstructors = True + , constructorTagModifier = map Char.toLower + } + +instance FromJSON BatchResultType where + parseJSON = genericParseJSON batchResultTypeOptions + +instance ToJSON BatchResultType where + toJSON = genericToJSON batchResultTypeOptions + +-- | A single result from a batch +data BatchResult = BatchResult + { custom_id :: Text + , result :: BatchResultType + } deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Pagination response for listing batches +data ListBatchesResponse = ListBatchesResponse + { data_ :: Vector BatchObject + , has_more :: Bool + , first_id :: Maybe Text + , last_id :: Maybe Text + } deriving stock (Generic, Show) + +instance FromJSON ListBatchesResponse where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ListBatchesResponse where + toJSON = genericToJSON aesonOptions + +-- | Servant API for @\/v1\/messages\/batches@ +type API = + "messages" + :> "batches" + :> ( ReqBody '[JSON] CreateBatch + :> Post '[JSON] BatchObject + :<|> Capture "batch_id" Text + :> Get '[JSON] BatchObject + :<|> QueryParam "limit" Natural + :> QueryParam "before_id" Text + :> QueryParam "after_id" Text + :> Get '[JSON] ListBatchesResponse + :<|> Capture "batch_id" Text + :> "cancel" + :> Post '[JSON] BatchObject + ) diff --git a/src/Claude/V1/Tool.hs b/src/Claude/V1/Tool.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1/Tool.hs @@ -0,0 +1,381 @@ +-- | Tool types for Claude API +-- +-- This module provides types and utilities for defining tools that Claude can use. +-- +-- Example usage: +-- +-- @ +-- import Claude.V1.Tool +-- +-- -- Define a simple tool +-- weatherTool :: Tool +-- weatherTool = functionTool \"get_weather\" +-- (Just \"Get the current weather for a location\") +-- (Aeson.object +-- [ \"type\" .= (\"object\" :: Text) +-- , \"properties\" .= Aeson.object +-- [ \"location\" .= Aeson.object +-- [ \"type\" .= (\"string\" :: Text) +-- , \"description\" .= (\"City and state, e.g. San Francisco, CA\" :: Text) +-- ] +-- ] +-- , \"required\" .= ([\"location\"] :: [Text]) +-- ]) +-- @ +module Claude.V1.Tool + ( -- * Types + Tool(..) + , ToolChoice(..) + , InputSchema(..) + -- * Tool definition (heterogeneous tools array) + , ToolDefinition(..) + , ToolSearchTool(..) + , ToolSearchToolType(..) + -- * Tool constructors + , functionTool + , simpleInputSchema + -- * ToolDefinition constructors + , inlineTool + , deferredTool + , toolSearchRegex + , toolSearchBm25 + -- * Code execution tool (PTC) + , codeExecutionTool + , allowedCallersCodeExecution + , allowCallers + -- * ToolChoice constructors + , toolChoiceAuto + , toolChoiceAny + , toolChoiceTool + -- * Helpers for processing tool calls + , isToolUse + , getToolUseBlocks + , makeToolResult + , makeToolResultError + ) where + +import Claude.Prelude + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Vector as Vector + +-- | Tool input schema (JSON Schema) +-- +-- The schema follows JSON Schema format. At minimum, specify @type_@ as \"object\". +data InputSchema = InputSchema + { type_ :: Text + , properties :: Maybe Value + , required :: Maybe (Vector Text) + } deriving stock (Eq, Generic, Show) + +instance FromJSON InputSchema where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON InputSchema where + toJSON = genericToJSON aesonOptions + +-- | Create a simple input schema with properties and required fields +simpleInputSchema + :: Value -- ^ Properties object + -> Vector Text -- ^ Required field names + -> InputSchema +simpleInputSchema props reqs = InputSchema + { type_ = "object" + , properties = Just props + , required = Just reqs + } + +-- | A tool that can be used by Claude +-- +-- Tools allow Claude to call external functions. When Claude decides to use a tool, +-- it will return a @tool_use@ content block with the tool name and input arguments. +data Tool = Tool + { name :: Text + , description :: Maybe Text + , input_schema :: InputSchema + } deriving stock (Eq, Generic, Show) + +instance FromJSON Tool where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Tool where + toJSON = genericToJSON aesonOptions + +-- | Create a function tool with a name, description, and JSON schema for parameters +-- +-- This is the primary way to define tools for Claude. +functionTool + :: Text -- ^ Tool name (must match [a-zA-Z0-9_-]+) + -> Maybe Text -- ^ Description of what the tool does + -> Value -- ^ JSON Schema for the input parameters + -> Tool +functionTool toolName toolDescription schema = Tool + { name = toolName + , description = toolDescription + , input_schema = InputSchema + { type_ = "object" + , properties = case schema of + Aeson.Object o -> case lookupKey "properties" o of + Just props -> Just props + Nothing -> Just schema + _ -> Just schema + , required = case schema of + Aeson.Object o -> case lookupKey "required" o of + Just (Aeson.Array arr) -> Just (Vector.mapMaybe getString arr) + _ -> Nothing + _ -> Nothing + } + } + where + getString (Aeson.String s) = Just s + getString _ = Nothing + lookupKey k obj = KeyMap.lookup (Key.fromText k) obj + +-- | Controls which tool the model should use +data ToolChoice + = ToolChoice_Auto + -- ^ Let Claude decide whether to use tools + | ToolChoice_Any + -- ^ Force Claude to use one of the provided tools + | ToolChoice_Tool { name :: Text } + -- ^ Force Claude to use a specific tool + deriving stock (Generic, Show) + +instance FromJSON ToolChoice where + parseJSON (Aeson.Object o) = do + t <- o Aeson..: "type" + case (t :: Text) of + "auto" -> pure ToolChoice_Auto + "any" -> pure ToolChoice_Any + "tool" -> ToolChoice_Tool <$> o Aeson..: "name" + _ -> fail "Unknown tool choice type" + parseJSON _ = fail "Invalid tool choice" + +instance ToJSON ToolChoice where + toJSON ToolChoice_Auto = Aeson.object ["type" Aeson..= ("auto" :: Text)] + toJSON ToolChoice_Any = Aeson.object ["type" Aeson..= ("any" :: Text)] + toJSON (ToolChoice_Tool n) = Aeson.object + [ "type" Aeson..= ("tool" :: Text) + , "name" Aeson..= n + ] + +-- | Convenience: auto tool choice (let Claude decide) +toolChoiceAuto :: ToolChoice +toolChoiceAuto = ToolChoice_Auto + +-- | Convenience: any tool choice (force tool use) +toolChoiceAny :: ToolChoice +toolChoiceAny = ToolChoice_Any + +-- | Convenience: specific tool choice +toolChoiceTool :: Text -> ToolChoice +toolChoiceTool = ToolChoice_Tool + +-- | Tool search tool type variants (for server-side tool search) +data ToolSearchToolType + = ToolSearchTool_Regex_20251119 + | ToolSearchTool_Bm25_20251119 + deriving stock (Eq, Show) + +instance FromJSON ToolSearchToolType where + parseJSON = Aeson.withText "ToolSearchToolType" $ \t -> case t of + "tool_search_tool_regex_20251119" -> pure ToolSearchTool_Regex_20251119 + "tool_search_tool_bm25_20251119" -> pure ToolSearchTool_Bm25_20251119 + _ -> fail $ "Unknown tool search tool type: " <> show t + +instance ToJSON ToolSearchToolType where + toJSON ToolSearchTool_Regex_20251119 = Aeson.String "tool_search_tool_regex_20251119" + toJSON ToolSearchTool_Bm25_20251119 = Aeson.String "tool_search_tool_bm25_20251119" + +-- | Tool search tool configuration +-- +-- Used to enable server-side tool search, which allows Claude to efficiently +-- search through large numbers of tools using regex or BM25 matching. +data ToolSearchTool = ToolSearchTool + { name :: Text + , type_ :: ToolSearchToolType + } deriving stock (Eq, Show) + +instance FromJSON ToolSearchTool where + parseJSON = Aeson.withObject "ToolSearchTool" $ \o -> do + name <- o Aeson..: "name" + type_ <- o Aeson..: "type" + pure ToolSearchTool{ name, type_ } + +instance ToJSON ToolSearchTool where + toJSON ToolSearchTool{ name, type_ } = Aeson.object + [ "name" Aeson..= name + , "type" Aeson..= type_ + ] + +-- | A tool definition for the @tools@ array +-- +-- The @tools@ array in Claude API requests is heterogeneous: +-- +-- * Function tools: regular tools with name, description, and input schema +-- * Tool search tools: server-side tool search configuration +-- * Code execution tool: for programmatic tool calling (PTC) +-- +-- Use 'inlineTool' or 'deferredTool' to wrap a 'Tool', or 'toolSearchRegex'/'toolSearchBm25' +-- to add tool search capability. Use 'codeExecutionTool' for PTC. +data ToolDefinition + = ToolDef_Function + { tool :: Tool + , defer_loading :: Maybe Bool + , allowed_callers :: Maybe (Vector Text) + } + | ToolDef_SearchTool ToolSearchTool + | ToolDef_CodeExecutionTool + { name :: Text + , type_ :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ToolDefinition where + parseJSON = Aeson.withObject "ToolDefinition" $ \o -> do + -- Check if this is a tool search tool or code execution tool by looking for "type" field + mType <- o Aeson..:? "type" + case mType of + Just t | isToolSearchType t -> do + searchTool <- Aeson.parseJSON (Aeson.Object o) + pure (ToolDef_SearchTool searchTool) + Just t | isCodeExecutionType t -> do + name <- o Aeson..: "name" + pure ToolDef_CodeExecutionTool{ name, type_ = t } + _ -> do + -- Parse as function tool + tool <- Aeson.parseJSON (Aeson.Object o) + defer_loading <- o Aeson..:? "defer_loading" + allowed_callers <- o Aeson..:? "allowed_callers" + pure ToolDef_Function{ tool, defer_loading, allowed_callers } + where + isToolSearchType :: Text -> Bool + isToolSearchType t = t == "tool_search_tool_regex_20251119" + || t == "tool_search_tool_bm25_20251119" + isCodeExecutionType :: Text -> Bool + isCodeExecutionType t = t == "code_execution_20250825" + +instance ToJSON ToolDefinition where + toJSON (ToolDef_Function Tool{ name, description, input_schema } defer_loading allowed_callers) = + Aeson.Object (baseMap <> optionalFields) + where + baseObj = Aeson.object $ + [ "name" Aeson..= name + , "input_schema" Aeson..= input_schema + ] <> maybe [] (\d -> ["description" Aeson..= d]) description + baseMap = case baseObj of + Aeson.Object m -> m + _ -> KeyMap.empty + optionalFields = KeyMap.fromList $ + maybe [] (\dl -> [("defer_loading", Aeson.toJSON dl)]) defer_loading <> + maybe [] (\ac -> [("allowed_callers", Aeson.toJSON ac)]) allowed_callers + toJSON (ToolDef_SearchTool searchTool) = Aeson.toJSON searchTool + toJSON (ToolDef_CodeExecutionTool name type_) = Aeson.object + [ "name" Aeson..= name + , "type" Aeson..= type_ + ] + +-- | Wrap a tool for inline (non-deferred) loading +inlineTool :: Tool -> ToolDefinition +inlineTool t = ToolDef_Function{ tool = t, defer_loading = Nothing, allowed_callers = Nothing } + +-- | Wrap a tool for deferred loading (used with tool search) +deferredTool :: Tool -> ToolDefinition +deferredTool t = ToolDef_Function{ tool = t, defer_loading = Just True, allowed_callers = Nothing } + +-- | Code execution tool for programmatic tool calling (PTC) +-- +-- Requires @anthropic-beta: advanced-tool-use-2025-11-20@ header. +-- When included in the tools array, Claude can write and execute code +-- to call other tools programmatically. +codeExecutionTool :: ToolDefinition +codeExecutionTool = ToolDef_CodeExecutionTool + { name = "code_execution" + , type_ = "code_execution_20250825" + } + +-- | Allowed callers for code execution (PTC) +-- +-- Use with 'allowCallers' to mark a function tool as callable by code execution. +allowedCallersCodeExecution :: Vector Text +allowedCallersCodeExecution = ["code_execution_20250825"] + +-- | Set allowed_callers on a function tool definition +-- +-- Only affects 'ToolDef_Function'; other tool types are returned unchanged. +-- +-- Example: +-- +-- @ +-- allowCallers allowedCallersCodeExecution (inlineTool myTool) +-- @ +allowCallers :: Vector Text -> ToolDefinition -> ToolDefinition +allowCallers callers (ToolDef_Function t dl _) = ToolDef_Function t dl (Just callers) +allowCallers _ td = td + +-- | Tool search using regex matching +-- +-- Requires @anthropic-beta: advanced-tool-use-2025-11-20@ header. +toolSearchRegex :: ToolDefinition +toolSearchRegex = ToolDef_SearchTool ToolSearchTool + { name = "tool_search_tool_regex" + , type_ = ToolSearchTool_Regex_20251119 + } + +-- | Tool search using BM25 matching +-- +-- Requires @anthropic-beta: advanced-tool-use-2025-11-20@ header. +toolSearchBm25 :: ToolDefinition +toolSearchBm25 = ToolDef_SearchTool ToolSearchTool + { name = "tool_search_tool_bm25" + , type_ = ToolSearchTool_Bm25_20251119 + } + +-- | Content block types (duplicated here for helper functions) +-- These mirror the types in Messages but are needed for the helper functions. + +-- | Check if a content block is a tool use block +isToolUse :: Value -> Bool +isToolUse (Aeson.Object o) = case KeyMap.lookup (Key.fromText "type") o of + Just (Aeson.String "tool_use") -> True + _ -> False +isToolUse _ = False + +-- | Extract tool use blocks from a response's content array +-- +-- Returns a list of (id, name, input) tuples for each tool_use block +getToolUseBlocks :: Vector Value -> [(Text, Text, Value)] +getToolUseBlocks content = Vector.toList $ Vector.mapMaybe extractToolUse content + where + extractToolUse (Aeson.Object o) = do + Aeson.String "tool_use" <- KeyMap.lookup (Key.fromText "type") o + Aeson.String toolId <- KeyMap.lookup (Key.fromText "id") o + Aeson.String toolName <- KeyMap.lookup (Key.fromText "name") o + toolInput <- KeyMap.lookup (Key.fromText "input") o + pure (toolId, toolName, toolInput) + extractToolUse _ = Nothing + +-- | Create a tool result content block for a successful tool call +makeToolResult + :: Text -- ^ tool_use_id from the tool_use block + -> Text -- ^ Result content (typically JSON encoded) + -> Value +makeToolResult toolUseId resultContent = Aeson.object + [ "type" Aeson..= ("tool_result" :: Text) + , "tool_use_id" Aeson..= toolUseId + , "content" Aeson..= resultContent + ] + +-- | Create a tool result content block for a failed tool call +makeToolResultError + :: Text -- ^ tool_use_id from the tool_use block + -> Text -- ^ Error message + -> Value +makeToolResultError toolUseId errorMsg = Aeson.object + [ "type" Aeson..= ("tool_result" :: Text) + , "tool_use_id" Aeson..= toolUseId + , "content" Aeson..= errorMsg + , "is_error" Aeson..= True + ] diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Claude.V1 (Methods(..)) +import Prelude hiding (id) + +import qualified Claude.V1 as V1 +import qualified Claude.V1.Messages as Messages +import qualified Claude.V1.Tool as Tool +import qualified Control.Concurrent as Concurrent +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson.Types +import Data.Foldable (toList) +import qualified Data.IORef as IORef +import Data.Maybe (mapMaybe) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Network.HTTP.Client as HTTP.Client +import qualified Network.HTTP.Client.TLS as TLS +import qualified Servant.Client as Client +import qualified System.Environment as Environment +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit + +main :: IO () +main = do + let managerSettings = + TLS.tlsManagerSettings + { HTTP.Client.managerResponseTimeout = + HTTP.Client.responseTimeoutNone + } + + manager <- TLS.newTlsManagerWith managerSettings + + baseUrl <- Client.parseBaseUrl "https://api.anthropic.com" + + let clientEnv = Client.mkClientEnv manager baseUrl + + key <- Environment.getEnv "ANTHROPIC_KEY" + + let model = "claude-sonnet-4-5-20250929" + let version = Just "2023-06-01" + let Methods{..} = V1.makeMethods clientEnv (Text.pack key) version + + let messagesMinimalTest = + HUnit.testCase "Create message - minimal" do + Messages.MessageResponse{ content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Say hello in one word." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 100 + } + + HUnit.assertBool "Response should have content" + (not (null content)) + + let messagesWithSystemTest = + HUnit.testCase "Create message - with system prompt" do + Messages.MessageResponse{ content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What are you?" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 100 + , Messages.system = Just "You are a helpful pirate. Respond in pirate speak." + } + + HUnit.assertBool "Response should have content" + (not (null content)) + + let messagesStreamingTest = + HUnit.testCase "Create message - streaming" do + acc <- IORef.newIORef Text.empty + done <- Concurrent.newEmptyMVar + + let onEvent (Left _err) = Concurrent.putMVar done () + onEvent (Right ev) = case ev of + Messages.Content_Block_Delta{ Messages.delta = d } -> + case d of + Messages.Delta_Text_Delta{ Messages.text = t } -> + IORef.modifyIORef' acc (<> t) + _ -> pure () + Messages.Message_Stop -> + Concurrent.putMVar done () + _ -> pure () + + createMessageStreamTyped + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Write a haiku about code." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 200 + } + onEvent + + _ <- Concurrent.takeMVar done + text <- IORef.readIORef acc + HUnit.assertBool "Expected non-empty streamed text" + (not (Text.null text)) + + let messagesConversationTest = + HUnit.testCase "Create message - multi-turn conversation" do + Messages.MessageResponse{ content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "My name is Alice." + ] + , Messages.cache_control = Nothing + } + , Messages.Message + { Messages.role = Messages.Assistant + , Messages.content = + [ Messages.textContent "Hello Alice! Nice to meet you." + ] + , Messages.cache_control = Nothing + } + , Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What is my name?" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 100 + } + + HUnit.assertBool "Response should have content" + (not (null content)) + + let toolUseTest = + HUnit.testCase "Create message - tool use" do + let calculatorTool = Tool.Tool + { Tool.name = "calculator" + , Tool.description = Just "Perform basic arithmetic" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "expression" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + , "description" Aeson..= ("Math expression like 2+2" :: Text.Text) + ] + ] + , Tool.required = Just ["expression"] + } + } + + Messages.MessageResponse{ stop_reason, content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What is 15 + 27? Use the calculator tool." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 200 + , Messages.tools = Just [Tool.inlineTool calculatorTool] + , Messages.tool_choice = Just Tool.ToolChoice_Any + } + + -- Should stop for tool use + HUnit.assertEqual "Should stop for tool use" + (Just Messages.Tool_Use) + stop_reason + + -- Should have a tool_use content block + let isToolUseBlock (Messages.ContentBlock_Tool_Use{}) = True + isToolUseBlock _ = False + let hasToolUse = any isToolUseBlock (toList content) + HUnit.assertBool "Should have tool_use content block" hasToolUse + + let tokenCountingTest = + HUnit.testCase "Count tokens" do + Messages.TokenCount{ input_tokens } <- + countTokens + Messages.CountTokensRequest + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Hello, world!" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.system = Nothing + , Messages.tools = Nothing + , Messages.tool_choice = Nothing + } + + HUnit.assertBool "Should have positive token count" + (input_tokens > 0) + + -- Tool search test requires beta header + let betaOptions = V1.defaultClientOptions + { V1.apiKey = Text.pack key + , V1.anthropicBeta = Just "advanced-tool-use-2025-11-20" + } + let V1.Methods{ V1.createMessage = createMessageBeta } = + V1.makeMethodsWith clientEnv betaOptions + + let toolSearchTest = + HUnit.testCase "Create message - tool search" do + -- Define several tools to search through + let weatherTool = Tool.Tool + { Tool.name = "get_weather" + , Tool.description = Just "Get the current weather for a location" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "location" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + ] + ] + , Tool.required = Just ["location"] + } + } + + let stockTool = Tool.Tool + { Tool.name = "get_stock_price" + , Tool.description = Just "Get the stock price for a ticker" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "ticker" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + ] + ] + , Tool.required = Just ["ticker"] + } + } + + let calculatorTool' = Tool.Tool + { Tool.name = "calculator" + , Tool.description = Just "Perform arithmetic calculations" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "expression" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + ] + ] + , Tool.required = Just ["expression"] + } + } + + -- Use tool search with deferred tools + let tools = + [ Tool.toolSearchRegex + , Tool.deferredTool weatherTool + , Tool.deferredTool stockTool + , Tool.deferredTool calculatorTool' + ] + + Messages.MessageResponse{ stop_reason, content } <- + createMessageBeta + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What's the weather in Paris?" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 200 + , Messages.tools = Just tools + , Messages.tool_choice = Just Tool.ToolChoice_Any + } + + -- Should stop for tool use + HUnit.assertEqual "Should stop for tool use" + (Just Messages.Tool_Use) + stop_reason + + -- Should have either a tool_use or server_tool_use content block + let isToolUseBlock' (Messages.ContentBlock_Tool_Use{}) = True + isToolUseBlock' (Messages.ContentBlock_Server_Tool_Use{}) = True + isToolUseBlock' _ = False + let hasToolUse' = any isToolUseBlock' (toList content) + HUnit.assertBool "Should have tool_use or server_tool_use content block" hasToolUse' + + -- Programmatic tool calling test (uses same beta header) + let programmaticToolCallingTest = + HUnit.testCase "Create message - programmatic tool calling" do + -- Define a simple tool for PTC + let queryTool = Tool.Tool + { Tool.name = "get_data" + , Tool.description = Just "Get data for a key" + , Tool.input_schema = Tool.InputSchema + { Tool.type_ = "object" + , Tool.properties = Just $ Aeson.object + [ "key" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + ] + ] + , Tool.required = Just ["key"] + } + } + + -- Tools: code execution + query tool with allowed_callers + let tools = + [ Tool.codeExecutionTool + , Tool.allowCallers Tool.allowedCallersCodeExecution (Tool.inlineTool queryTool) + ] + + -- Initial request prompting code execution + let initialMessage = Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent + "Use code execution to call the get_data tool twice: once with key='alpha' and once with key='beta'. Then calculate the sum of the returned values." + ] + , Messages.cache_control = Nothing + } + + -- First request + Messages.MessageResponse{ stop_reason, content, container } <- + createMessageBeta + Messages._CreateMessage + { Messages.model = model + , Messages.messages = [initialMessage] + , Messages.max_tokens = 4096 + , Messages.tools = Just tools + } + + -- Should stop for tool use + HUnit.assertEqual "Should stop for tool use" + (Just Messages.Tool_Use) + stop_reason + + -- Should have a server_tool_use for code_execution + let hasCodeExecution = any isCodeExecutionServerToolUse (toList content) + HUnit.assertBool "Should have server_tool_use for code_execution" hasCodeExecution + + -- Should have container info + HUnit.assertBool "Should have container info" (container /= Nothing) + + -- Should have tool_use with programmatic caller + let programmaticToolUses = + [ () + | Messages.ContentBlock_Tool_Use{ Messages.caller = Just (Messages.ToolCaller_CodeExecution{}) } + <- toList content + ] + HUnit.assertBool "Should have at least one programmatic tool call" + (not (null programmaticToolUses)) + + -- Multi-turn loop: continue until end_turn or code_execution_tool_result + let containerId = fmap (\Messages.ContainerInfo{ Messages.id = cid } -> cid) container + + -- Build initial assistant message from first response + let assistantContent1 = mapMaybe Messages.contentBlockToContent (toList content) + let assistantMessage1 = Messages.Message + { Messages.role = Messages.Assistant + , Messages.content = Vector.fromList assistantContent1 + , Messages.cache_control = Nothing + } + let toolResults1 = processTestToolCalls content + let userMessage1 = Messages.Message + { Messages.role = Messages.User + , Messages.content = Vector.fromList toolResults1 + , Messages.cache_control = Nothing + } + + -- Loop function + let loop :: [Messages.Message] -> Maybe Text.Text -> Int -> IO () + loop _ _ turn | turn > 5 = HUnit.assertFailure "Max turns reached" + loop msgs containerId' turn = do + Messages.MessageResponse{ stop_reason = sr, content = c, container = cont } <- + createMessageBeta + Messages._CreateMessage + { Messages.model = model + , Messages.messages = Vector.fromList msgs + , Messages.max_tokens = 4096 + , Messages.tools = Just tools + , Messages.container = containerId' + } + + let newContainerId = case cont of + Just Messages.ContainerInfo{ Messages.id = cid } -> Just cid + Nothing -> containerId' + + let hasCodeExecutionResult = any isCodeExecutionResult (toList c) + let isEndTurn = sr == Just Messages.End_Turn + + if hasCodeExecutionResult || isEndTurn + then pure () -- Success! + else if sr == Just Messages.Tool_Use + then do + -- Build next assistant and user messages + let assistantContentN = mapMaybe Messages.contentBlockToContent (toList c) + let assistantMessageN = Messages.Message + { Messages.role = Messages.Assistant + , Messages.content = Vector.fromList assistantContentN + , Messages.cache_control = Nothing + } + let toolResultsN = processTestToolCalls c + let userMessageN = Messages.Message + { Messages.role = Messages.User + , Messages.content = Vector.fromList toolResultsN + , Messages.cache_control = Nothing + } + loop (msgs <> [assistantMessageN, userMessageN]) newContainerId (turn + 1) + else HUnit.assertFailure $ "Unexpected stop_reason: " <> show sr + + -- Start the loop + loop [initialMessage, assistantMessage1, userMessage1] containerId 1 + + let tests = + [ messagesMinimalTest + , messagesWithSystemTest + , messagesStreamingTest + , messagesConversationTest + , toolUseTest + , tokenCountingTest + , toolSearchTest + , programmaticToolCallingTest + ] + + Tasty.defaultMain (Tasty.testGroup "Claude API Tests" tests) + +-- | Check if a content block is a server_tool_use for code_execution +isCodeExecutionServerToolUse :: Messages.ContentBlock -> Bool +isCodeExecutionServerToolUse (Messages.ContentBlock_Server_Tool_Use{ Messages.name = "code_execution" }) = True +isCodeExecutionServerToolUse _ = False + +-- | Check if a content block is a code_execution_tool_result +isCodeExecutionResult :: Messages.ContentBlock -> Bool +isCodeExecutionResult (Messages.ContentBlock_Code_Execution_Tool_Result{}) = True +isCodeExecutionResult _ = False + +-- | Process tool calls for testing - returns fake results +processTestToolCalls :: Vector.Vector Messages.ContentBlock -> [Messages.Content] +processTestToolCalls content = + [ Messages.Content_Tool_Result + { Messages.tool_use_id = toolId + , Messages.content = Just result + , Messages.is_error = Nothing + } + | Messages.ContentBlock_Tool_Use{ Messages.id = toolId, Messages.name = toolName, Messages.input = toolInput, Messages.caller = _ } + <- toList content + , let result = case toolName of + "get_data" -> case Aeson.Types.parseMaybe (Aeson.withObject "input" (\o -> o Aeson..: "key")) toolInput of + Just ("alpha" :: Text.Text) -> "{\"value\": 100}" + Just "beta" -> "{\"value\": 200}" + _ -> "{\"value\": 0}" + _ -> "{\"error\": \"unknown tool\"}" + ]