diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +2.5.2: + +- Add `ResponseWithMetadata` wrapper and `lookupHeader` helper for accessing raw HTTP response headers from API calls. +- Add `createResponseWithMetadata` for non-streaming responses with headers. +- Add `createResponseStreamWithMetadata` and `createResponseStreamTypedWithMetadata` for streaming responses with headers (delivered via callback before events flow). +- Existing `createResponse`, `createResponseStream`, and `createResponseStreamTyped` remain unchanged. + 2.5.1: - Add 28 missing `ResponseStreamEvent` constructors covering all event types from the OpenAPI spec (lifecycle, reasoning, refusal, audio, image generation, MCP, and custom tool call events). diff --git a/openai.cabal b/openai.cabal --- a/openai.cabal +++ b/openai.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: openai -version: 2.5.1 +version: 2.5.2 synopsis: Servant bindings to OpenAI description: This package provides comprehensive and type-safe bindings to OpenAI, providing both a Servant interface and @@ -30,6 +30,7 @@ build-depends: base >=4.15.0.0 && < 5 , aeson , bytestring + , case-insensitive , containers , filepath , http-api-data @@ -37,10 +38,10 @@ , http-client-tls , http-types , servant - , servant-multipart-api - , servant-client - , servant-multipart-client - , text + , servant-multipart-api + , servant-client + , servant-multipart-client + , text , time , unordered-containers , vector diff --git a/src/OpenAI/V1.hs b/src/OpenAI/V1.hs --- a/src/OpenAI/V1.hs +++ b/src/OpenAI/V1.hs @@ -125,8 +125,10 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as SBS import qualified Data.ByteString.Char8 as S8 +import qualified Data.CaseInsensitive as CI import qualified Data.IORef as IORef import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding import qualified Network.HTTP.Client as HTTP.Client import qualified Network.HTTP.Client.TLS as TLS import qualified Network.HTTP.Types.Status as Status @@ -198,7 +200,7 @@ :<|> deleteChatKitThread :<|> _listChatKitThreadItems ) - :<|> ( createResponse + :<|> ( createResponse_ :<|> retrieveResponse :<|> cancelResponse :<|> listResponseInputItems_ @@ -314,6 +316,9 @@ createTranscription a = createTranscription_ (boundary, a) createTranslation a = createTranslation_ (boundary, a) + createResponse = createResponse_ + createResponseWithMetadata = + postJSONWithMetadata "/v1/responses" createEmbeddings a = toVector (createEmbeddings_ a) listFineTuningJobs a b = toVector (listFineTuningJobs_ a b) listFineTuningEvents a b c = toVector (listFineTuningEvents_ a b c) @@ -342,15 +347,26 @@ -- Streaming implementation using http-client and SSE parsing createResponseStream req onEvent = do + createResponseStreamWithMetadata req (\_ -> pure ()) onEvent + + createResponseStreamWithMetadata req onMetadata onEvent = do let req' = req{ Responses.stream = Just True } - ssePostJSON "/v1/responses" req' onEvent + ssePostJSON "/v1/responses" req' onMetadata onEvent createResponseStreamTyped :: CreateResponse -> (Either Text Responses.ResponseStreamEvent -> IO ()) -> IO () createResponseStreamTyped req onEvent = - createResponseStream req $ \ev -> case ev of + createResponseStreamTypedWithMetadata req (\_ -> pure ()) onEvent + + createResponseStreamTypedWithMetadata + :: CreateResponse + -> (Responses.ResponseWithMetadata () -> IO ()) + -> (Either Text Responses.ResponseStreamEvent -> IO ()) + -> IO () + createResponseStreamTypedWithMetadata req onMetadata onEvent = + createResponseStreamWithMetadata req onMetadata $ \ev -> case ev of Left err -> onEvent (Left err) Right val -> case Aeson.fromJSON val of Aeson.Error msg -> onEvent (Left (Text.pack msg)) @@ -359,7 +375,7 @@ -- Streaming implementation for chat completions createChatCompletionStream req onEvent = do let req' = req{ Chat.Completions.stream = Just True } - ssePostJSON "/v1/chat/completions" req' onEvent + ssePostJSON "/v1/chat/completions" req' (\_ -> pure ()) onEvent createChatCompletionStreamTyped :: CreateChatCompletion @@ -372,12 +388,78 @@ Aeson.Error msg -> onEvent (Left (Text.pack msg)) Aeson.Success e -> onEvent (Right e) + postJSONWithMetadata + :: (ToJSON a, FromJSON b) + => String + -> a + -> IO (Responses.ResponseWithMetadata b) + postJSONWithMetadata path body = 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 = + [ ("Authorization", S8.pack (Text.unpack authorization)) + , ("Accept", "application/json") + , ("Content-Type", "application/json") + ] + let headers1 = case organizationID of + Nothing -> headers0 + Just org -> ("OpenAI-Organization", S8.pack (Text.unpack org)) : headers0 + let headers = case projectID of + Nothing -> headers1 + Just proj -> ("OpenAI-Project", S8.pack (Text.unpack proj)) : 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 + let responseHeaders = adaptHeaders (HTTP.Client.responseHeaders response) + bodyChunks <- HTTP.Client.brConsume (HTTP.Client.responseBody response) + let responseBody = SBS.concat bodyChunks + let st = HTTP.Client.responseStatus response + if not (Status.statusIsSuccessful st) + then throwClientError + ( "HTTP error " + <> renderIntegral (Status.statusCode st) + <> " " + <> (Text.pack (S8.unpack (Status.statusMessage st))) + <> (if SBS.null responseBody + then "" + else ": " <> decodeText responseBody) + ) + else case Aeson.eitherDecodeStrict responseBody of + Left err -> + throwClientError + ( "Failed to decode response JSON: " + <> Text.pack err + ) + Right responseBody' -> + pure Responses.ResponseWithMetadata + { Responses.body = responseBody' + , Responses.response_headers = responseHeaders + } + ssePostJSON :: ToJSON a => String -> a + -> (Responses.ResponseWithMetadata () -> IO ()) -> (Either Text Aeson.Value -> IO ()) -> IO () - ssePostJSON path body onEvent = do + ssePostJSON path body onMetadata onEvent = do let base = Client.baseUrl clientEnv let secure = case Client.baseUrlScheme base of Client.Http -> False @@ -411,6 +493,11 @@ } HTTP.Client.withResponse request (Client.manager clientEnv) $ \response -> do + onMetadata + Responses.ResponseWithMetadata + { Responses.body = () + , Responses.response_headers = adaptHeaders (HTTP.Client.responseHeaders response) + } -- Short-circuit on non-2xx HTTP statuses and surface a single error event let st = HTTP.Client.responseStatus response if not (Status.statusIsSuccessful st) @@ -479,10 +566,30 @@ ('/':_) -> p _ -> '/':p + adaptHeaders + :: [(CI.CI SBS.ByteString, SBS.ByteString)] + -> [(Text, Text)] + adaptHeaders = fmap adaptHeader + + adaptHeader (headerName, headerValue) = + ( decodeText (CI.original headerName) + , decodeText headerValue + ) + + decodeText bytes = + case Text.Encoding.decodeUtf8' bytes of + Left _ -> Text.pack (S8.unpack bytes) + Right text -> text + stripCR bs = case S8.unsnoc bs of Just (initBs, '\r') -> initBs _ -> bs + throwClientError :: Text -> IO a + throwClientError message = + Exception.throwIO + (Client.ConnectionError (Exception.toException (userError (Text.unpack message)))) + unsnoc [] = Nothing unsnoc xs = Just (init xs, last xs) @@ -535,15 +642,28 @@ -> (Either Text Chat.Completions.Stream.ChatCompletionStreamEvent -> IO ()) -> IO () , createResponse :: CreateResponse -> IO ResponseObject + , createResponseWithMetadata + :: CreateResponse + -> IO (Responses.ResponseWithMetadata ResponseObject) , createResponseStream :: CreateResponse -> (Either Text Aeson.Value -> IO ()) -> IO () + , createResponseStreamWithMetadata + :: CreateResponse + -> (Responses.ResponseWithMetadata () -> IO ()) + -> (Either Text Aeson.Value -> IO ()) + -> IO () , createEmbeddings :: CreateEmbeddings -> IO (Vector EmbeddingObject) , createResponseStreamTyped :: CreateResponse -> (Either Text Responses.ResponseStreamEvent -> IO ()) -> IO () + , createResponseStreamTypedWithMetadata + :: CreateResponse + -> (Responses.ResponseWithMetadata () -> IO ()) + -> (Either Text Responses.ResponseStreamEvent -> IO ()) + -> IO () , createFineTuningJob :: CreateFineTuningJob -> IO JobObject , listFineTuningJobs :: Maybe Text @@ -754,14 +874,14 @@ = Header' [ Required, Strict ] "Authorization" Text :> Header' [ Optional, Strict ] "OpenAI-Organization" Text :> Header' [ Optional, Strict ] "OpenAI-Project" Text - :> "v1" - :> ( Audio.API - :<|> Chat.Completions.API - :<|> ChatKit.API - :<|> Responses.API - :<|> Embeddings.API - :<|> FineTuning.Jobs.API - :<|> Batches.API + :> "v1" + :> ( Audio.API + :<|> Chat.Completions.API + :<|> ChatKit.API + :<|> Responses.API + :<|> Embeddings.API + :<|> FineTuning.Jobs.API + :<|> Batches.API :<|> Files.API :<|> Images.API :<|> Uploads.API diff --git a/src/OpenAI/V1/Responses.hs b/src/OpenAI/V1/Responses.hs --- a/src/OpenAI/V1/Responses.hs +++ b/src/OpenAI/V1/Responses.hs @@ -41,6 +41,8 @@ , ResponseStreamEvent(..) , Tool(..) , ResponseObject(..) + , ResponseWithMetadata(..) + , lookupHeader , ResponseUsage(..) , InputTokensDetails(..) , OutputTokensDetails(..) @@ -54,6 +56,7 @@ import Control.Applicative ((<|>)) import Data.Aeson (Object) import OpenAI.Prelude hiding (Input(..), input) +import qualified Data.Text as T import OpenAI.V1.AutoOr (AutoOr(..)) import OpenAI.V1.ListOf (ListOf) import OpenAI.V1.Models (Model) @@ -1277,3 +1280,20 @@ :> "input_items" :> Get '[JSON] (ListOf InputItem) ) + +-- | Body + response headers from an API call. +data ResponseWithMetadata a = ResponseWithMetadata + { body :: a + , response_headers :: [(Text, Text)] + } deriving stock (Eq, Generic, Show) + +-- | Case-insensitive lookup for a response header. +lookupHeader :: Text -> ResponseWithMetadata a -> Maybe Text +lookupHeader key ResponseWithMetadata{ response_headers } = + foldr select Nothing response_headers + where + target = T.toLower key + + select (name, value) acc + | T.toLower name == target = Just value + | otherwise = acc diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -10,7 +10,7 @@ import qualified Data.Aeson.KeyMap as KeyMap import Control.Exception (SomeException, catch) import Data.Foldable (toList) -import Data.Maybe (listToMaybe) +import Data.Maybe (isJust, listToMaybe) import OpenAI.V1 (Methods(..)) import OpenAI.V1.Audio.Speech (CreateSpeech(..), Voice(..), _CreateSpeech) import OpenAI.V1.Audio.Transcriptions (CreateTranscription(..)) @@ -908,8 +908,8 @@ let responsesMinimalTest = HUnit.testCase "Responses - minimal" do - _ <- - createResponse + responseWithMetadata <- + createResponseWithMetadata Responses._CreateResponse { Responses.model = chatModel, Responses.input = Just (Responses.Input @@ -932,6 +932,16 @@ Responses.tool_choice = Nothing } + let Responses.ResponseObject{ Responses.output = outputItems } = + Responses.body responseWithMetadata + + HUnit.assertBool + "Expected non-empty response output" + (not (null (toList outputItems))) + HUnit.assertBool + "Expected content-type metadata header" + (isJust (Responses.lookupHeader "content-type" responseWithMetadata)) + return () let responsesStreamingHaikuTest = @@ -960,8 +970,10 @@ } acc <- IORef.newIORef (Text.empty) + responseMetadata <- IORef.newIORef Nothing done <- Concurrent.newEmptyMVar + let onMetadata metadata = IORef.writeIORef responseMetadata (Just metadata) let onEvent (Left _err) = Concurrent.putMVar done () onEvent (Right ev) = case ev of Responses.ResponseTextDeltaEvent{ Responses.delta = d } -> @@ -970,11 +982,16 @@ Concurrent.putMVar done () _ -> pure () - createResponseStreamTyped req onEvent + createResponseStreamTypedWithMetadata req onMetadata onEvent _ <- Concurrent.takeMVar done text <- IORef.readIORef acc + metadata <- IORef.readIORef responseMetadata HUnit.assertBool "Expected non-empty streamed text" (not (Text.null text)) + HUnit.assertBool "Expected streaming response metadata" (isJust metadata) + HUnit.assertBool + "Expected content-type header in stream metadata" + (maybe False (isJust . Responses.lookupHeader "content-type") metadata) return ()