diff --git a/baikai-claude.cabal b/baikai-claude.cabal --- a/baikai-claude.cabal +++ b/baikai-claude.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai-claude -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Anthropic Claude providers for the baikai abstraction description: Wraps the claude Haskell package as a Baikai Provider for both the Anthropic API and the @@ -34,20 +34,23 @@ exposed-modules: Baikai.Provider.Claude.Api Baikai.Provider.Claude.Cli + Baikai.Provider.Claude.ErrorClass Baikai.Provider.Claude.Interactive build-depends: , aeson - , baikai ^>=0.1.1 + , baikai ^>=0.2.0 , base >=4.20 && <5 , base64-bytestring , bytestring + , case-insensitive , claude , containers , cradle , generic-lens , http-client , http-client-tls + , http-types , lens ^>=5.3 , servant-client , streamly >=0.11 && <0.13 @@ -61,20 +64,25 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + other-modules: ErrorClassSpec -- cradle (used by Baikai.Provider.Claude.Interactive) requires the threaded RTS. ghc-options: -threaded -with-rtsopts=-N build-depends: , aeson - , baikai ^>=0.1.1 + , baikai ^>=0.2.0 , baikai-claude - , base >=4.20 && <5 + , base >=4.20 && <5 , bytestring + , case-insensitive , claude + , containers , generic-lens - , lens ^>=5.3 - , streamly-core >=0.3 && <0.5 + , http-types + , lens ^>=5.3 + , servant-client + , streamly-core >=0.3 && <0.5 , tasty , tasty-hunit - , text ^>=2.1 + , text ^>=2.1 , vector diff --git a/src/Baikai/Provider/Claude/Api.hs b/src/Baikai/Provider/Claude/Api.hs --- a/src/Baikai/Provider/Claude/Api.hs +++ b/src/Baikai/Provider/Claude/Api.hs @@ -34,9 +34,11 @@ import Baikai.Context (Context (..)) import Baikai.Cost (_Cost) import Baikai.Cost.Pricing qualified as Pricing +import Baikai.Error (BaikaiError, invalidRequest) import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) +import Baikai.Provider.Claude.ErrorClass (classifyErrorValue, classifyException) import Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, @@ -52,8 +54,9 @@ DeltaPayload (..), IndexPayload (..), StartPayload (..), - TerminalPayload (..), ToolCallEndPayload (..), + doneTerminal, + errorTerminal, ) import Baikai.ThinkingLevel (ThinkingLevel, thinkingTokenBudget) import Baikai.Tool qualified as Tool @@ -63,7 +66,7 @@ import Claude.V1.Tool qualified as ClaudeTool import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Exception (SomeException, displayException, try) +import Control.Exception (SomeException, try) import Control.Lens ((%~), (&), (.~), (^.)) import Data.Aeson (Value, (.=)) import Data.Aeson qualified as Aeson @@ -126,7 +129,8 @@ Right call -> do ch <- newChan :: IO (Chan (Maybe Messages.MessageStreamEvent)) tref <- newIORef False - _ <- forkIO (worker call ch tref) + eref <- newIORef Nothing + _ <- forkIO (worker call ch eref) startTime <- getCurrentTime let initialState = ProducerState @@ -134,7 +138,8 @@ pending = [], assembler = emptyAssembler m startTime, finished = False, - terminalRef = tref + terminalRef = tref, + errInfoRef = eref } pure (Stream.unfoldrM step initialState) @@ -173,9 +178,9 @@ worker :: ClaudeCall -> Chan (Maybe Messages.MessageStreamEvent) -> - IORef Bool -> + IORef (Maybe BaikaiError) -> IO () -worker call ch _terminalRef = do +worker call ch errInfoRef = do let Claude.Methods {Claude.createMessageStreamTyped = stream'} = call ^. #methods r <- try @SomeException $ @@ -184,7 +189,11 @@ Right ev -> writeChan ch (Just ev) case r of Right () -> pure () - Left e -> writeChan ch (Just (errorEvent (Text.pack (displayException e)))) + -- An HTTP-level exception carries an HTTP status; classify it and + -- stash the structured error. The worker writes no terminal event, + -- so the consumer reaches its end-of-stream recovery path, which + -- reads this ref. (See 'step' / 'unexpectedEoS'.) + Left e -> writeIORef errInfoRef (Just (classifyException e)) writeChan ch Nothing where errorEvent :: Text -> Messages.MessageStreamEvent @@ -196,7 +205,10 @@ pending :: ![AssistantMessageEvent], assembler :: !Assembler, finished :: !Bool, - terminalRef :: !(IORef Bool) + terminalRef :: !(IORef Bool), + -- | Set by the worker when an HTTP-level exception is caught, so the + -- end-of-stream recovery path can surface a categorised error. + errInfoRef :: !(IORef (Maybe BaikaiError)) } deriving stock (Generic) @@ -222,7 +234,8 @@ then pure Nothing else do now <- getCurrentTime - let (ev, ass') = unexpectedEoS now (s ^. #assembler) + mErr <- readIORef (s ^. #errInfoRef) + let (ev, ass') = unexpectedEoS now mErr (s ^. #assembler) writeTerminal s ev pure ( Just @@ -258,15 +271,17 @@ EventError {} -> True _ -> False --- | The recovery path: channel closed before any terminal event. -unexpectedEoS :: UTCTime -> Assembler -> (AssistantMessageEvent, Assembler) -unexpectedEoS now ass = - let msg = - finalMessageOnError - ass - now - "claude stream ended without message_stop" - in (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}, ass) +-- | The recovery path: channel closed before any terminal event. When +-- the worker stored a classified HTTP error ('Just be'), surface it as a +-- structured 'EventError'; otherwise report the unexpected end of stream. +unexpectedEoS :: + UTCTime -> Maybe BaikaiError -> Assembler -> (AssistantMessageEvent, Assembler) +unexpectedEoS now mErr ass = + let errText = case mErr of + Just be -> be ^. #message + Nothing -> "claude stream ended without message_stop" + msg = finalMessageOnError ass now errText + in (EventError (errorTerminal Stop.ErrorReason msg mErr), ass) -- | Translation state across one streaming call. data Assembler = Assembler @@ -330,11 +345,12 @@ in ([], ass & #stopReason .~ stopR & #usage .~ u') Messages.Message_Stop -> let msg = finalMessage ass now - in ([EventDone TerminalPayload {reason = ass ^. #stopReason, message = msg}], ass) + in ([EventDone (doneTerminal (ass ^. #stopReason) msg)], ass) Messages.Error {Messages.error = errVal} -> let errText = renderAnthropicError errVal + mErr = classifyErrorValue errVal msg = finalMessageOnError ass now errText - in ([EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}], ass) + in ([EventError (errorTerminal Stop.ErrorReason msg mErr)], ass) handleBlockStart :: Int -> @@ -504,7 +520,7 @@ Msg.errorMessage = Just errText, Msg.timestamp = now } - pure (EventError TerminalPayload {reason = Stop.ErrorReason, message = msg}) + pure (EventError (errorTerminal Stop.ErrorReason msg (Just (invalidRequest errText)))) renderAnthropicError :: Value -> Text renderAnthropicError v = case v of diff --git a/src/Baikai/Provider/Claude/Cli.hs b/src/Baikai/Provider/Claude/Cli.hs --- a/src/Baikai/Provider/Claude/Cli.hs +++ b/src/Baikai/Provider/Claude/Cli.hs @@ -25,7 +25,7 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..)) -import Baikai.Error (BaikaiError (..)) +import Baikai.Error (decodeError, processError, providerError) import Baikai.Message (AssistantPayload (..)) import Baikai.Model (Model) import Baikai.Options (Options) @@ -141,16 +141,16 @@ decodeResult :: ByteString -> IO ClaudeCliResult decodeResult bs = case eitherDecodeStrict bs of - Left err -> throwIO (DecodeError (Text.pack err)) + Left err -> throwIO (decodeError (Text.pack err)) Right (Aeson.Array events) -> case findResultEvent events of - Nothing -> throwIO (DecodeError "claude -p: no result event in stdout array") + Nothing -> throwIO (decodeError "claude -p: no result event in stdout array") Just ev -> case parseEither parseJSON ev of - Left err -> throwIO (DecodeError (Text.pack err)) + Left err -> throwIO (decodeError (Text.pack err)) Right r -> pure r Right v@(Aeson.Object _) -> case parseEither parseJSON v of - Left err -> throwIO (DecodeError (Text.pack err)) + Left err -> throwIO (decodeError (Text.pack err)) Right r -> pure r - Right _ -> throwIO (DecodeError "claude -p: expected JSON object or array") + Right _ -> throwIO (decodeError "claude -p: expected JSON object or array") findResultEvent :: Vector Value -> Maybe Value findResultEvent = Vector.find isResult @@ -179,11 +179,11 @@ & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir end <- getCurrentTime case exitCode of - ExitFailure n -> throwIO (ProcessError n (Internal.decodeUtf8Lenient err)) + ExitFailure n -> throwIO (processError n (Internal.decodeUtf8Lenient err)) ExitSuccess -> do r <- decodeResult out if is_error r - then throwIO (ProviderError (result r)) + then throwIO (providerError (result r)) else pure (mkResponse m start end (result r)) mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response @@ -201,7 +201,8 @@ Resp.api = AnthropicMessagesCli, Resp.provider = m ^. #provider, Resp.responseId = Nothing, - Resp.latencyMs = millisBetween start end + Resp.latencyMs = millisBetween start end, + Resp.errorInfo = Nothing } millisBetween :: UTCTime -> UTCTime -> Integer diff --git a/src/Baikai/Provider/Claude/ErrorClass.hs b/src/Baikai/Provider/Claude/ErrorClass.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/ErrorClass.hs @@ -0,0 +1,129 @@ +-- | Map failures from the Anthropic SDK onto baikai's typed +-- 'BaikaiError'. Two entry points cover the two ways a failure reaches +-- the provider: 'classifyException' for an exception thrown by the +-- @servant-client@ HTTP layer (carrying an HTTP status), and +-- 'classifyErrorValue' for an Anthropic @error@ event that arrives +-- mid-stream as a JSON 'Value'. +module Baikai.Provider.Claude.ErrorClass + ( classifyException, + classifyErrorValue, + -- | Exposed for testing the HTTP-status mapping without a live call. + responseToError, + ) +where + +import Baikai.Error + ( BaikaiError (..), + ErrorCategory (..), + bodyIndicatesOverflow, + classifyHttpStatusWithBody, + decodeError, + providerError, + ) +import Control.Exception (SomeException, displayException, fromException) +import Data.Aeson (Value (..)) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.CaseInsensitive qualified as CI +import Data.Foldable (toList) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.Encoding.Error qualified as Text +import Network.HTTP.Types.Status (statusCode) +import Servant.Client (ClientError, ResponseF (..)) +import Servant.Client qualified as Servant +import Text.Read (readMaybe) + +-- | Convert any exception caught from the Anthropic SDK into a +-- categorised 'BaikaiError'. Recognises @servant-client@ 'ClientError'; +-- anything else degrades to a generic provider error carrying the +-- displayed exception text. +classifyException :: SomeException -> BaikaiError +classifyException ex = case fromException ex of + Just clientErr -> fromClientError clientErr + Nothing -> providerError (Text.pack (displayException ex)) + +fromClientError :: ClientError -> BaikaiError +fromClientError clientErr = case clientErr of + Servant.FailureResponse _req resp -> responseToError resp + Servant.DecodeFailure detail _ -> decodeError detail + Servant.UnsupportedContentType _ _ -> decodeError "unsupported content type in Anthropic response" + Servant.InvalidContentTypeHeader _ -> decodeError "invalid content-type header in Anthropic response" + Servant.ConnectionError exc -> + (providerError ("connection error: " <> Text.pack (displayException exc))) + { category = TransientError + } + +-- | Build a 'BaikaiError' from a non-2xx HTTP response: status code, +-- @Retry-After@ header (when integer-valued), and a snippet of the body +-- (which also feeds context-overflow detection). +responseToError :: ResponseF LBS.ByteString -> BaikaiError +responseToError resp = + BaikaiError + { category = classifyHttpStatusWithBody status retryAfter body, + message = msg, + httpStatus = Just status, + retryAfterSeconds = retryAfter, + exitCode = Nothing + } + where + status = statusCode (responseStatusCode resp) + body = decodeLenient (LBS.toStrict (responseBody resp)) + retryAfter = parseRetryAfter (responseHeaders resp) + snippet = Text.take 300 (Text.strip body) + msg = + "HTTP " + <> Text.pack (show status) + <> (if Text.null snippet then "" else ": " <> snippet) + +-- | Look up an integer @Retry-After@ header value (seconds). The HTTP +-- date form is not parsed and yields 'Nothing'. +parseRetryAfter :: Seq (CI.CI ByteString, ByteString) -> Maybe Int +parseRetryAfter headers = do + raw <- lookup (CI.mk "Retry-After") (toList headers) + readMaybe (Text.unpack (Text.strip (decodeLenient raw))) + +decodeLenient :: ByteString -> Text +decodeLenient = Text.decodeUtf8With Text.lenientDecode + +-- | Classify a mid-stream Anthropic @error@ event. The value is the +-- inner error object, e.g. @{"type":"overloaded_error","message":"…"}@; +-- it may also arrive wrapped under an @"error"@ key. Returns 'Nothing' +-- when no error @type@ can be found (the caller keeps the plain text). +classifyErrorValue :: Value -> Maybe BaikaiError +classifyErrorValue v = do + let obj = unwrap v + ty <- stringField "type" obj + let detail = maybe ty id (stringField "message" obj) + cat = anthropicTypeToCategory ty detail + Just (providerError detail) {category = cat} + where + unwrap (Object o) = case KeyMap.lookup "error" o of + Just (Object inner) -> inner + _ -> o + unwrap _ = KeyMap.empty + stringField k o = case KeyMap.lookup k o of + Just (String t) -> Just t + _ -> Nothing + +-- | Map an Anthropic error @type@ string (plus its message, for the +-- overflow special case) to a category. +anthropicTypeToCategory :: Text -> Text -> ErrorCategory +anthropicTypeToCategory ty detail = case ty of + "authentication_error" -> AuthError + "permission_error" -> AuthError + "rate_limit_error" -> RateLimited + "overloaded_error" -> TransientError + "api_error" -> TransientError + "timeout_error" -> TransientError + "not_found_error" -> InvalidRequest + "request_too_large" -> ContextOverflow + "invalid_request_error" + | bodyIndicatesOverflow detail -> ContextOverflow + | otherwise -> InvalidRequest + _ + | bodyIndicatesOverflow detail -> ContextOverflow + | otherwise -> OtherError diff --git a/test/ErrorClassSpec.hs b/test/ErrorClassSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorClassSpec.hs @@ -0,0 +1,105 @@ +module ErrorClassSpec (tests) where + +import Baikai.Error (BaikaiError (..), ErrorCategory (..)) +import Baikai.Provider.Claude.ErrorClass + ( classifyErrorValue, + classifyException, + responseToError, + ) +import Control.Exception (toException) +import Data.Aeson (Value, object, (.=)) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.CaseInsensitive qualified as CI +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Network.HTTP.Types.Status (mkStatus) +import Network.HTTP.Types.Version (http11) +import Servant.Client (ResponseF (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Provider.Claude.ErrorClass" + [ httpStatusTests, + streamedErrorTests, + fallbackTests + ] + +-- | Build a synthetic servant 'ResponseF' for the HTTP-status mapper. +mkResp :: Int -> [(ByteString, ByteString)] -> LBS.ByteString -> ResponseF LBS.ByteString +mkResp status hdrs body = + Response + { responseStatusCode = mkStatus status "", + responseHeaders = Seq.fromList [(CI.mk n, v) | (n, v) <- hdrs], + responseHttpVersion = http11, + responseBody = body + } + +httpStatusTests :: TestTree +httpStatusTests = + testGroup + "responseToError (HTTP status)" + [ testCase "429 + Retry-After -> RateLimited with hint" $ do + let e = responseToError (mkResp 429 [("Retry-After", "30")] "slow down") + category e @?= RateLimited + httpStatus e @?= Just 429 + retryAfterSeconds e @?= Just 30, + testCase "429 without Retry-After -> RateLimited, no hint" $ do + let e = responseToError (mkResp 429 [] "slow down") + category e @?= RateLimited + retryAfterSeconds e @?= Nothing, + testCase "401 -> AuthError" $ + category (responseToError (mkResp 401 [] "bad key")) @?= AuthError, + testCase "400 with overflow body -> ContextOverflow" $ + category (responseToError (mkResp 400 [] "prompt is too long: 9000 tokens")) + @?= ContextOverflow, + testCase "400 with ordinary body -> InvalidRequest" $ + category (responseToError (mkResp 400 [] "missing field model")) + @?= InvalidRequest, + testCase "503 -> TransientError" $ + category (responseToError (mkResp 503 [] "")) @?= TransientError, + testCase "non-integer Retry-After is ignored" $ + retryAfterSeconds (responseToError (mkResp 429 [("Retry-After", "Wed, 21 Oct 2026 07:28:00 GMT")] "")) + @?= Nothing + ] + +streamedErrorTests :: TestTree +streamedErrorTests = + testGroup + "classifyErrorValue (mid-stream error event)" + [ testCase "rate_limit_error -> RateLimited" $ + fmap category (classifyErrorValue (anthropicError "rate_limit_error" "slow")) + @?= Just RateLimited, + testCase "overloaded_error -> TransientError" $ + fmap category (classifyErrorValue (anthropicError "overloaded_error" "busy")) + @?= Just TransientError, + testCase "authentication_error -> AuthError" $ + fmap category (classifyErrorValue (anthropicError "authentication_error" "nope")) + @?= Just AuthError, + testCase "invalid_request_error with overflow text -> ContextOverflow" $ + fmap category (classifyErrorValue (anthropicError "invalid_request_error" "prompt is too long")) + @?= Just ContextOverflow, + testCase "invalid_request_error otherwise -> InvalidRequest" $ + fmap category (classifyErrorValue (anthropicError "invalid_request_error" "bad")) + @?= Just InvalidRequest, + testCase "value without a type -> Nothing" $ + classifyErrorValue (object ["message" .= ("hi" :: Text.Text)]) @?= Nothing + ] + +fallbackTests :: TestTree +fallbackTests = + testGroup + "classifyException fallback" + [ testCase "non-ClientError exception -> OtherError, text preserved" $ do + let e = classifyException (toException (userError "weird failure")) + category e @?= OtherError + assertBool "message keeps the original text" $ + "weird failure" `Text.isInfixOf` message e + ] + +-- | The inner error object Anthropic streams as the @error@ field. +anthropicError :: Text.Text -> Text.Text -> Value +anthropicError ty msg = object ["type" .= ty, "message" .= msg] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import Data.Generics.Labels () import Data.Text qualified as Text import Data.Vector qualified as Vector +import ErrorClassSpec qualified import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -22,7 +23,8 @@ [ commandRenderingTest, compatDetectionTest, rejectsImageToolResultsTest, - responseFormatMappingTest + responseFormatMappingTest, + ErrorClassSpec.tests ] -- | A 'JsonSchema' on 'Options.responseFormat' maps onto Anthropic's