baikai-claude 0.1.1.0 → 0.2.0.0

raw patch · 6 files changed

+299/−38 lines, 6 filesdep +case-insensitivedep +http-typesdep ~baikaiPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, http-types

Dependency ranges changed: baikai

API changes (from Hackage documentation)

Files

• baikai-claude.cabal +15/−7
• src/Baikai/Provider/Claude/Api.hs +37/−21
• src/Baikai/Provider/Claude/Cli.hs +10/−9
• src/Baikai/Provider/Claude/ErrorClass.hs +129/−0
• test/ErrorClassSpec.hs +105/−0
• test/Main.hs +3/−1

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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