never executed always true always false
1 module PureClaw.Providers.Anthropic
2 ( -- * Provider type (constructor intentionally NOT exported)
3 AnthropicProvider
4 , mkAnthropicProvider
5 -- * Errors
6 , AnthropicError (..)
7 -- * Request/response encoding (exported for testing)
8 , encodeRequest
9 , decodeResponse
10 ) where
11
12 import Control.Exception
13 import Data.Aeson
14 import Data.Aeson.Types
15 import Data.ByteString (ByteString)
16 import Data.ByteString.Lazy qualified as BL
17 import Data.Maybe
18 import Data.Text (Text)
19 import Data.Text qualified as T
20 import Network.HTTP.Client qualified as HTTP
21 import Network.HTTP.Types.Status qualified as Status
22
23 import PureClaw.Core.Errors
24 import PureClaw.Core.Types
25 import PureClaw.Providers.Class
26 import PureClaw.Security.Secrets
27
28 -- | Anthropic API provider. Constructor is not exported — use
29 -- 'mkAnthropicProvider'.
30 data AnthropicProvider = AnthropicProvider
31 { _ap_manager :: HTTP.Manager
32 , _ap_apiKey :: ApiKey
33 }
34
35 -- | Create an Anthropic provider with an HTTP manager and API key.
36 mkAnthropicProvider :: HTTP.Manager -> ApiKey -> AnthropicProvider
37 mkAnthropicProvider = AnthropicProvider
38
39 instance Provider AnthropicProvider where
40 complete = anthropicComplete
41
42 -- | Errors from the Anthropic API.
43 data AnthropicError
44 = AnthropicAPIError Int ByteString -- ^ HTTP status code + response body
45 | AnthropicParseError Text -- ^ JSON parse/decode error
46 deriving stock (Show)
47
48 instance Exception AnthropicError
49
50 instance ToPublicError AnthropicError where
51 toPublicError (AnthropicAPIError 429 _) = RateLimitError
52 toPublicError (AnthropicAPIError 401 _) = NotAllowedError
53 toPublicError _ = TemporaryError "Provider error"
54
55 -- | Anthropic Messages API base URL.
56 anthropicBaseUrl :: String
57 anthropicBaseUrl = "https://api.anthropic.com/v1/messages"
58
59 -- | Call the Anthropic Messages API.
60 anthropicComplete :: AnthropicProvider -> CompletionRequest -> IO CompletionResponse
61 anthropicComplete provider req = do
62 initReq <- HTTP.parseRequest anthropicBaseUrl
63 let httpReq = initReq
64 { HTTP.method = "POST"
65 , HTTP.requestBody = HTTP.RequestBodyLBS (encodeRequest req)
66 , HTTP.requestHeaders =
67 [ ("x-api-key", withApiKey (_ap_apiKey provider) id)
68 , ("anthropic-version", "2023-06-01")
69 , ("content-type", "application/json")
70 ]
71 }
72 resp <- HTTP.httpLbs httpReq (_ap_manager provider)
73 let status = Status.statusCode (HTTP.responseStatus resp)
74 if status /= 200
75 then throwIO (AnthropicAPIError status (BL.toStrict (HTTP.responseBody resp)))
76 else case decodeResponse (HTTP.responseBody resp) of
77 Left err -> throwIO (AnthropicParseError (T.pack err))
78 Right response -> pure response
79
80 -- | Encode a completion request as JSON for the Anthropic API.
81 encodeRequest :: CompletionRequest -> BL.ByteString
82 encodeRequest req = encode $ object $
83 [ "model" .= unModelId (_cr_model req)
84 , "max_tokens" .= fromMaybe 4096 (_cr_maxTokens req)
85 , "messages" .= map encodeMsg (_cr_messages req)
86 ]
87 ++ maybe [] (\s -> ["system" .= s]) (_cr_systemPrompt req)
88 ++ if null (_cr_tools req)
89 then maybe [] (\tc -> ["tool_choice" .= encodeToolChoice tc]) (_cr_toolChoice req)
90 else ("tools" .= map encodeTool (_cr_tools req))
91 : maybe [] (\tc -> ["tool_choice" .= encodeToolChoice tc]) (_cr_toolChoice req)
92
93 encodeMsg :: Message -> Value
94 encodeMsg msg = object
95 [ "role" .= roleToText (_msg_role msg)
96 , "content" .= map encodeContentBlock (_msg_content msg)
97 ]
98
99 encodeContentBlock :: ContentBlock -> Value
100 encodeContentBlock (TextBlock t) = object
101 [ "type" .= ("text" :: Text)
102 , "text" .= t
103 ]
104 encodeContentBlock (ToolUseBlock callId name input) = object
105 [ "type" .= ("tool_use" :: Text)
106 , "id" .= unToolCallId callId
107 , "name" .= name
108 , "input" .= input
109 ]
110 encodeContentBlock (ToolResultBlock callId content isErr) = object $
111 [ "type" .= ("tool_result" :: Text)
112 , "tool_use_id" .= unToolCallId callId
113 , "content" .= content
114 ]
115 ++ ["is_error" .= True | isErr]
116
117 encodeTool :: ToolDefinition -> Value
118 encodeTool td = object
119 [ "name" .= _td_name td
120 , "description" .= _td_description td
121 , "input_schema" .= _td_inputSchema td
122 ]
123
124 encodeToolChoice :: ToolChoice -> Value
125 encodeToolChoice AutoTool = object ["type" .= ("auto" :: Text)]
126 encodeToolChoice AnyTool = object ["type" .= ("any" :: Text)]
127 encodeToolChoice (SpecificTool name) = object
128 [ "type" .= ("tool" :: Text)
129 , "name" .= name
130 ]
131
132 -- | Decode an Anthropic API response into a 'CompletionResponse'.
133 decodeResponse :: BL.ByteString -> Either String CompletionResponse
134 decodeResponse bs = eitherDecode bs >>= parseEither parseResp
135 where
136 parseResp :: Value -> Parser CompletionResponse
137 parseResp = withObject "AnthropicResponse" $ \o -> do
138 contentArr <- o .: "content"
139 blocks <- mapM parseBlock contentArr
140 modelText <- o .: "model"
141 usageObj <- o .: "usage"
142 inToks <- usageObj .: "input_tokens"
143 outToks <- usageObj .: "output_tokens"
144 pure CompletionResponse
145 { _crsp_content = blocks
146 , _crsp_model = ModelId modelText
147 , _crsp_usage = Just (Usage inToks outToks)
148 }
149
150 parseBlock :: Value -> Parser ContentBlock
151 parseBlock = withObject "ContentBlock" $ \b -> do
152 bType <- b .: "type"
153 case (bType :: Text) of
154 "text" -> TextBlock <$> b .: "text"
155 "tool_use" -> do
156 callId <- b .: "id"
157 name <- b .: "name"
158 input <- b .: "input"
159 pure (ToolUseBlock (ToolCallId callId) name input)
160 other -> fail $ "Unknown content block type: " <> T.unpack other