diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,22 @@ +1.4.0: + +- Expand prompt caching support: + - Add top-level `cache_control` on `CreateMessage` (automatic caching). + - Add `ttl` support on `CacheControl` via `CacheTTL`. + - Add cache-control helpers: + - `ephemeralCacheWithTTL` + - `ephemeralCacheWithTTLSeconds` + - `ephemeralCacheWithTTLDuration` +- Add structured system prompt support: + - `SystemPrompt` (string or blocks) + - `SystemBlock` with per-block `cache_control` + - `systemText`, `systemBlocks`, `systemTextBlock`, `systemTextBlockCached` + - `CreateMessage.system` and `CountTokensRequest.system` now use `Maybe SystemPrompt` + - breaking: `system = Just someTextVar` (where `someTextVar :: Text`) now needs `system = Just (systemText someTextVar)` +- Add tool-level cache control support: + - `ToolDefinition` variants now accept optional `cache_control` + - new helper `withToolCacheControl` + 1.3.1: - Remove `advanced-tool-use-2025-11-20` beta header requirement — tool search, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,6 +34,28 @@ traverse_ display content ``` +## Prompt caching + +The bindings support prompt caching at multiple levels: + +- top-level request (`CreateMessage.cache_control`) +- system blocks (`SystemBlock.cache_control`) +- message/content blocks (`Message.cache_control`, text/image content block cache control) +- tool definitions (`withToolCacheControl`) + +```haskell +MessageResponse{ usage } <- createMessage _CreateMessage + { model = "claude-sonnet-4-5-20250929" + , max_tokens = 1024 + , cache_control = Just (ephemeralCacheWithTTLDuration "1h") + , system = Just $ systemBlocks + [ systemTextBlockCached ephemeralCache "You are a coding assistant." + ] + , messages = + [ Message{ role = User, content = [ textContent "Summarize this file." ] } ] + } +``` + ## Setup ### Using Nix with Flakes (Recommended) diff --git a/claude.cabal b/claude.cabal --- a/claude.cabal +++ b/claude.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: claude -version: 1.3.1 +version: 1.4.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 @@ -47,6 +47,7 @@ Claude.V1.Messages.Batches Claude.V1.Tool other-modules: Claude.Prelude + Claude.V1.CacheControl default-extensions: DataKinds , DeriveAnyClass , DeriveGeneric diff --git a/src/Claude/V1/CacheControl.hs b/src/Claude/V1/CacheControl.hs new file mode 100644 --- /dev/null +++ b/src/Claude/V1/CacheControl.hs @@ -0,0 +1,62 @@ +module Claude.V1.CacheControl + ( CacheControl(..) + , CacheTTL(..) + , ephemeralCache + , ephemeralCacheWithTTL + , ephemeralCacheWithTTLSeconds + , ephemeralCacheWithTTLDuration + ) where + +import Claude.Prelude +import qualified Data.Aeson as Aeson + +-- | Cache TTL configuration for prompt caching. +-- +-- Supports both numeric seconds and duration strings for forward compatibility. +data CacheTTL + = CacheTTLSeconds Natural + | CacheTTLDuration Text + deriving stock (Eq, Show) + +instance FromJSON CacheTTL where + parseJSON n@(Aeson.Number _) = CacheTTLSeconds <$> Aeson.parseJSON n + parseJSON (Aeson.String t) = pure (CacheTTLDuration t) + parseJSON _ = fail "CacheTTL must be a number (seconds) or string duration" + +instance ToJSON CacheTTL where + toJSON (CacheTTLSeconds n) = Aeson.toJSON n + toJSON (CacheTTLDuration t) = Aeson.toJSON t + +-- | Cache control for prompt caching. +data CacheControl = CacheControl + { type_ :: Text + , ttl :: Maybe CacheTTL + } deriving stock (Eq, 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" + , ttl = Nothing + } + +-- | Convenience constructor for ephemeral cache control with TTL. +ephemeralCacheWithTTL :: CacheTTL -> CacheControl +ephemeralCacheWithTTL cacheTTL = CacheControl + { type_ = "ephemeral" + , ttl = Just cacheTTL + } + +-- | Convenience constructor for ephemeral cache control with TTL in seconds. +ephemeralCacheWithTTLSeconds :: Natural -> CacheControl +ephemeralCacheWithTTLSeconds = ephemeralCacheWithTTL . CacheTTLSeconds + +-- | Convenience constructor for ephemeral cache control with TTL duration text. +ephemeralCacheWithTTLDuration :: Text -> CacheControl +ephemeralCacheWithTTLDuration = ephemeralCacheWithTTL . CacheTTLDuration diff --git a/src/Claude/V1/Messages.hs b/src/Claude/V1/Messages.hs --- a/src/Claude/V1/Messages.hs +++ b/src/Claude/V1/Messages.hs @@ -61,6 +61,7 @@ , codeExecutionTool , allowedCallersCodeExecution , allowCallers + , withToolCacheControl , toolChoiceAuto , toolChoiceAny , toolChoiceTool @@ -76,7 +77,18 @@ , TokenCount(..) -- * Prompt caching , CacheControl(..) + , CacheTTL(..) , ephemeralCache + , ephemeralCacheWithTTL + , ephemeralCacheWithTTLSeconds + , ephemeralCacheWithTTLDuration + -- * System prompt helpers + , SystemPrompt(..) + , SystemBlock(..) + , systemText + , systemBlocks + , systemTextBlock + , systemTextBlockCached -- * Convenience constructors , textContent , imageContent @@ -87,6 +99,14 @@ ) where import Claude.Prelude +import Claude.V1.CacheControl + ( CacheControl(..) + , CacheTTL(..) + , ephemeralCache + , ephemeralCacheWithTTL + , ephemeralCacheWithTTLDuration + , ephemeralCacheWithTTLSeconds + ) import Claude.V1.Tool ( InputSchema(..) , Tool(..) @@ -104,6 +124,7 @@ , toolChoiceAny , toolChoiceAuto , toolChoiceTool + , withToolCacheControl , toolSearchBm25 , toolSearchRegex ) @@ -134,21 +155,64 @@ 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) +-- | A system prompt block. +-- +-- Use @type_ = \"text\"@ for text system blocks. +data SystemBlock = SystemBlock + { type_ :: Text + , text :: Text + , cache_control :: Maybe CacheControl + } deriving stock (Eq, Generic, Show) -instance FromJSON CacheControl where +instance FromJSON SystemBlock where parseJSON = genericParseJSON aesonOptions -instance ToJSON CacheControl where +instance ToJSON SystemBlock where toJSON = genericToJSON aesonOptions --- | Convenience constructor for ephemeral cache control -ephemeralCache :: CacheControl -ephemeralCache = CacheControl{ type_ = "ephemeral" } +-- | System prompt, either a plain string or an array of system blocks. +data SystemPrompt + = SystemPromptText Text + | SystemPromptBlocks (Vector SystemBlock) + deriving stock (Eq, Show) +instance IsString SystemPrompt where + fromString = SystemPromptText . fromString + +instance FromJSON SystemPrompt where + parseJSON (Aeson.String t) = pure (SystemPromptText t) + parseJSON (Aeson.Array arr) = + SystemPromptBlocks <$> traverse Aeson.parseJSON arr + parseJSON _ = fail "SystemPrompt must be a string or array of system blocks" + +instance ToJSON SystemPrompt where + toJSON (SystemPromptText t) = Aeson.String t + toJSON (SystemPromptBlocks blocks) = Aeson.toJSON blocks + +-- | Create a plain-text system prompt. +systemText :: Text -> SystemPrompt +systemText = SystemPromptText + +-- | Create a block-based system prompt. +systemBlocks :: Vector SystemBlock -> SystemPrompt +systemBlocks = SystemPromptBlocks + +-- | Create a text system block without cache control. +systemTextBlock :: Text -> SystemBlock +systemTextBlock t = SystemBlock + { type_ = "text" + , text = t + , cache_control = Nothing + } + +-- | Create a text system block with cache control. +systemTextBlockCached :: CacheControl -> Text -> SystemBlock +systemTextBlockCached cc t = SystemBlock + { type_ = "text" + , text = t + , cache_control = Just cc + } + -- | Text content block data TextContent = TextContent { text :: Text @@ -836,7 +900,10 @@ { model :: Text , messages :: Vector Message , max_tokens :: Natural - , system :: Maybe Text + , system :: Maybe SystemPrompt + -- ^ System prompt, either plain text or structured system blocks. + , cache_control :: Maybe CacheControl + -- ^ Top-level automatic prompt caching configuration. , temperature :: Maybe Double , top_p :: Maybe Double , top_k :: Maybe Natural @@ -873,6 +940,7 @@ , messages = mempty , max_tokens = 1024 , system = Nothing + , cache_control = Nothing , temperature = Nothing , top_p = Nothing , top_k = Nothing @@ -1014,7 +1082,7 @@ data CountTokensRequest = CountTokensRequest { model :: Text , messages :: Vector Message - , system :: Maybe Text + , system :: Maybe SystemPrompt , tools :: Maybe (Vector ToolDefinition) , tool_choice :: Maybe ToolChoice } deriving stock (Generic, Show) diff --git a/src/Claude/V1/Tool.hs b/src/Claude/V1/Tool.hs --- a/src/Claude/V1/Tool.hs +++ b/src/Claude/V1/Tool.hs @@ -31,6 +31,13 @@ , ToolDefinition(..) , ToolSearchTool(..) , ToolSearchToolType(..) + -- * Prompt caching + , CacheControl(..) + , CacheTTL(..) + , ephemeralCache + , ephemeralCacheWithTTL + , ephemeralCacheWithTTLSeconds + , ephemeralCacheWithTTLDuration -- * Tool constructors , functionTool , strictFunctionTool @@ -44,6 +51,7 @@ , codeExecutionTool , allowedCallersCodeExecution , allowCallers + , withToolCacheControl -- * ToolChoice constructors , toolChoiceAuto , toolChoiceAny @@ -56,6 +64,14 @@ ) where import Claude.Prelude +import Claude.V1.CacheControl + ( CacheControl(..) + , CacheTTL(..) + , ephemeralCache + , ephemeralCacheWithTTL + , ephemeralCacheWithTTLDuration + , ephemeralCacheWithTTLSeconds + ) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Key @@ -265,11 +281,16 @@ { tool :: Tool , defer_loading :: Maybe Bool , allowed_callers :: Maybe (Vector Text) + , cache_control :: Maybe CacheControl } - | ToolDef_SearchTool ToolSearchTool + | ToolDef_SearchTool + { tool_search_tool :: ToolSearchTool + , cache_control :: Maybe CacheControl + } | ToolDef_CodeExecutionTool { name :: Text , type_ :: Text + , cache_control :: Maybe CacheControl } deriving stock (Eq, Show) @@ -277,19 +298,32 @@ 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" + cache_control <- o Aeson..:? "cache_control" case mType of Just t | isToolSearchType t -> do searchTool <- Aeson.parseJSON (Aeson.Object o) - pure (ToolDef_SearchTool searchTool) + pure ToolDef_SearchTool + { tool_search_tool = searchTool + , cache_control = cache_control + } Just t | isCodeExecutionType t -> do name <- o Aeson..: "name" - pure ToolDef_CodeExecutionTool{ name, type_ = t } + pure ToolDef_CodeExecutionTool + { name + , type_ = t + , cache_control = cache_control + } _ -> 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 } + pure ToolDef_Function + { tool + , defer_loading + , allowed_callers + , cache_control = cache_control + } where isToolSearchType :: Text -> Bool isToolSearchType t = t == "tool_search_tool_regex_20251119" @@ -298,7 +332,7 @@ isCodeExecutionType t = t == "code_execution_20250825" instance ToJSON ToolDefinition where - toJSON (ToolDef_Function Tool{ name, description, input_schema, strict } defer_loading allowed_callers) = + toJSON (ToolDef_Function Tool{ name, description, input_schema, strict } defer_loading allowed_callers cache_control) = Aeson.Object (baseMap <> optionalFields) where baseObj = Aeson.object $ @@ -311,20 +345,37 @@ optionalFields = KeyMap.fromList $ maybe [] (\dl -> [("defer_loading", Aeson.toJSON dl)]) defer_loading <> maybe [] (\ac -> [("allowed_callers", Aeson.toJSON ac)]) allowed_callers <> - maybe [] (\s -> [("strict", Aeson.toJSON s)]) strict - toJSON (ToolDef_SearchTool searchTool) = Aeson.toJSON searchTool - toJSON (ToolDef_CodeExecutionTool name type_) = Aeson.object + maybe [] (\s -> [("strict", Aeson.toJSON s)]) strict <> + maybe [] (\cc -> [("cache_control", Aeson.toJSON cc)]) cache_control + toJSON (ToolDef_SearchTool searchTool cache_control) = + case Aeson.toJSON searchTool of + Aeson.Object baseMap -> + Aeson.Object $ + baseMap <> KeyMap.fromList + (maybe [] (\cc -> [("cache_control", Aeson.toJSON cc)]) cache_control) + other -> other + toJSON (ToolDef_CodeExecutionTool name type_ cache_control) = Aeson.object $ [ "name" Aeson..= name , "type" Aeson..= type_ - ] + ] <> maybe [] (\cc -> ["cache_control" Aeson..= cc]) cache_control -- | Wrap a tool for inline (non-deferred) loading inlineTool :: Tool -> ToolDefinition -inlineTool t = ToolDef_Function{ tool = t, defer_loading = Nothing, allowed_callers = Nothing } +inlineTool t = ToolDef_Function + { tool = t + , defer_loading = Nothing + , allowed_callers = Nothing + , cache_control = 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 } +deferredTool t = ToolDef_Function + { tool = t + , defer_loading = Just True + , allowed_callers = Nothing + , cache_control = Nothing + } -- | Code execution tool for programmatic tool calling (PTC) -- @@ -334,6 +385,7 @@ codeExecutionTool = ToolDef_CodeExecutionTool { name = "code_execution" , type_ = "code_execution_20250825" + , cache_control = Nothing } -- | Allowed callers for code execution (PTC) @@ -352,21 +404,34 @@ -- allowCallers allowedCallersCodeExecution (inlineTool myTool) -- @ allowCallers :: Vector Text -> ToolDefinition -> ToolDefinition -allowCallers callers (ToolDef_Function t dl _) = ToolDef_Function t dl (Just callers) +allowCallers callers (ToolDef_Function t dl _ cc) = ToolDef_Function t dl (Just callers) cc allowCallers _ td = td +-- | Set cache_control on a tool definition. +withToolCacheControl :: CacheControl -> ToolDefinition -> ToolDefinition +withToolCacheControl cc (ToolDef_Function t dl ac _) = ToolDef_Function t dl ac (Just cc) +withToolCacheControl cc (ToolDef_SearchTool t _) = ToolDef_SearchTool t (Just cc) +withToolCacheControl cc (ToolDef_CodeExecutionTool n t _) = + ToolDef_CodeExecutionTool n t (Just cc) + -- | Tool search using regex matching toolSearchRegex :: ToolDefinition -toolSearchRegex = ToolDef_SearchTool ToolSearchTool - { name = "tool_search_tool_regex" - , type_ = ToolSearchTool_Regex_20251119 +toolSearchRegex = ToolDef_SearchTool + { tool_search_tool = ToolSearchTool + { name = "tool_search_tool_regex" + , type_ = ToolSearchTool_Regex_20251119 + } + , cache_control = Nothing } -- | Tool search using BM25 matching toolSearchBm25 :: ToolDefinition -toolSearchBm25 = ToolDef_SearchTool ToolSearchTool - { name = "tool_search_tool_bm25" - , type_ = ToolSearchTool_Bm25_20251119 +toolSearchBm25 = ToolDef_SearchTool + { tool_search_tool = ToolSearchTool + { name = "tool_search_tool_bm25" + , type_ = ToolSearchTool_Bm25_20251119 + } + , cache_control = Nothing } -- | Content block types (duplicated here for helper functions) diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -52,6 +52,94 @@ let version = Just "2023-06-01" let Methods{..} = V1.makeMethods clientEnv (Text.pack key) version + let systemPromptStringLiveTest = + HUnit.testCase "Create message - system prompt string" do + Messages.MessageResponse{ content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Say exactly: system-string-ok" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 32 + , Messages.system = Just "Respond with exactly: system-string-ok" + } + + HUnit.assertBool "Response should have content" + (not (null content)) + + let systemPromptBlocksLiveTest = + HUnit.testCase "Create message - system prompt blocks with cache control" do + Messages.MessageResponse{ content } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Follow the system instructions." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 64 + , Messages.system = Just $ Messages.systemBlocks + [ Messages.systemTextBlockCached + Messages.ephemeralCache + "Respond with exactly: system-block-ok" + ] + } + + HUnit.assertBool "Response should have content" + (not (null content)) + + let toolDefinitionCacheControlLiveTest = + HUnit.testCase "Create message - tool cache_control" do + let weatherTool = Tool.functionTool + "get_weather" + (Just "Get weather for a location") + $ Aeson.object + [ "properties" Aeson..= Aeson.object + [ "location" Aeson..= Aeson.object + [ "type" Aeson..= ("string" :: Text.Text) + ] + ] + , "required" Aeson..= (["location"] :: [Text.Text]) + ] + + Messages.MessageResponse{ stop_reason } <- + createMessage + Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "What's the weather in SF? Use the tool." + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 200 + , Messages.tools = Just + [ Tool.withToolCacheControl + Messages.ephemeralCache + (Tool.inlineTool weatherTool) + ] + , Messages.tool_choice = Just Tool.ToolChoice_Any + } + + HUnit.assertEqual "Should stop for tool use" + (Just Messages.Tool_Use) + stop_reason + let messagesMinimalTest = HUnit.testCase "Create message - minimal" do Messages.MessageResponse{ content } <- @@ -419,6 +507,47 @@ HUnit.assertBool "Expected non-empty streamed text" (not (Text.null text)) + let promptCachingLiveTest = + HUnit.testCase "Create message - prompt caching" do + let largeSystemText = + Text.intercalate " " (replicate 6000 ("cacheable-guidance" :: Text.Text)) + let systemPrompt = Messages.systemBlocks + [ Messages.systemTextBlockCached Messages.ephemeralCache largeSystemText + ] + let request = Messages._CreateMessage + { Messages.model = model + , Messages.messages = + [ Messages.Message + { Messages.role = Messages.User + , Messages.content = + [ Messages.textContent "Respond with exactly: cachetest" + ] + , Messages.cache_control = Nothing + } + ] + , Messages.max_tokens = 64 + , Messages.system = Just systemPrompt + , Messages.cache_control = Just Messages.ephemeralCache + } + + Messages.MessageResponse{ Messages.usage = usage1 } <- createMessage request + Messages.MessageResponse{ Messages.usage = usage2 } <- createMessage request + + let firstCreatedCache = + maybe False (> 0) (Messages.cache_creation_input_tokens usage1) + let firstReadCache = + maybe False (> 0) (Messages.cache_read_input_tokens usage1) + let readCache = + maybe False (> 0) (Messages.cache_read_input_tokens usage2) + + HUnit.assertBool + "First request should create or read prompt cache tokens" + (firstCreatedCache || firstReadCache) + + HUnit.assertBool + "Second request should read prompt cache tokens" + readCache + let inferenceGeoLiveTest = HUnit.testCase "Create message - inference_geo" do Messages.MessageResponse{ content } <- @@ -735,7 +864,10 @@ HUnit.assertFailure $ "Unexpected stop_reason: " <> show other let tests = - [ messagesMinimalTest + [ systemPromptStringLiveTest + , systemPromptBlocksLiveTest + , toolDefinitionCacheControlLiveTest + , messagesMinimalTest , messagesWithSystemTest , messagesStreamingTest , messagesConversationTest @@ -745,6 +877,7 @@ , strictToolUseTest , adaptiveThinkingTest , adaptiveThinkingStreamingTest + , promptCachingLiveTest , inferenceGeoLiveTest , compactionLiveTest , fastModeLiveTest