diff --git a/IHP/OpenAI.hs b/IHP/OpenAI.hs --- a/IHP/OpenAI.hs +++ b/IHP/OpenAI.hs @@ -14,11 +14,31 @@ import qualified OpenSSL.Session as SSL import qualified Data.Text as Text import qualified Control.Retry as Retry -import qualified Control.Exception as Exception +import qualified Control.Exception.Safe as Exception import Control.Applicative ((<|>)) import qualified Data.Aeson.Key as Key import qualified Data.Maybe as Maybe +import qualified Network.URI as URI +import qualified Data.Text.Encoding as Text +import qualified System.IO.Streams.Attoparsec as Streams +import Data.Aeson.Parser (json') +import Control.Monad +data Config + = Config + { baseUrl :: !Text + , secretKey :: !Text + } + +defaultConfig :: Text -> Config +defaultConfig secretKey = Config { secretKey, baseUrl = openAIBaseUrl } + +openAIBaseUrl :: Text +openAIBaseUrl = "https://api.openai.com/v1" + +googleBaseUrl :: Text +googleBaseUrl = "https://generativelanguage.googleapis.com/v1beta/openai" + data CompletionRequest = CompletionRequest { messages :: ![Message] , model :: !Text @@ -29,14 +49,20 @@ , stream :: !Bool , responseFormat :: !(Maybe ResponseFormat) , tools :: ![Tool] + , reasoningEffort :: !(Maybe Text) + , parallelToolCalls :: !(Maybe Bool) + , extraHeaders :: [(Text, Text)] } deriving (Eq, Show) +data CacheControl = Ephemeral deriving (Eq, Show) + data Message = Message { role :: !Role , content :: !Text , name :: !(Maybe Text) , toolCallId :: !(Maybe Text) , toolCalls :: ![ToolCall] + , cacheControl :: !(Maybe CacheControl) } deriving (Eq, Show) data Role @@ -69,17 +95,19 @@ deriving (Eq, Show) instance ToJSON CompletionRequest where - toJSON CompletionRequest { model, messages, maxTokens, temperature, presencePenalty, frequencePenalty, stream, responseFormat, tools } = - object - [ "model" .= model - , "messages" .= messages - , "max_tokens" .= maxTokens - , "stream" .= stream - , "temperature" .= temperature - , "presence_penalty" .= presencePenalty - , "frequency_penalty" .= frequencePenalty - , "response_format" .= responseFormat - , "tools" .= emptyListToNothing tools + toJSON CompletionRequest { model, messages, maxTokens, temperature, presencePenalty, frequencePenalty, stream, responseFormat, tools, reasoningEffort, parallelToolCalls } = + object $ Maybe.catMaybes + [ Just ("model" .= model) + , Just ("messages" .= messages) + , ("max_tokens" .=) <$> maxTokens + , Just ("stream" .= stream) + , ("temperature" .=) <$> temperature + , ("presence_penalty" .=) <$> presencePenalty + , ("frequency_penalty" .=) <$> frequencePenalty + , ("response_format" .=) <$> responseFormat + , ("tools" .=) <$> emptyListToNothing tools + , ("reasoning_effort" .=) <$> reasoningEffort + , ("parallel_tool_calls" .=) <$> parallelToolCalls ] instance ToJSON Role where @@ -89,9 +117,19 @@ toJSON ToolRole = toJSON ("tool" :: Text) instance ToJSON Message where - toJSON Message { role, content, name, toolCallId, toolCalls } = object $ Maybe.catMaybes + toJSON Message { role, content, name, toolCallId, toolCalls, cacheControl } = object $ Maybe.catMaybes [ Just ("role" .= role) - , Just ("content" .= content) + , Just ("content" .= + case cacheControl of + Just cacheControl -> toJSON [ + object + [ "type" .= ("text" :: Text) + , "text" .= Just content + , "cache_control" .= cacheControl + ] + ] + Nothing -> toJSON content + ) , ("name" .=) <$> name , ("tool_call_id" .=) <$> toolCallId , if null toolCalls then Nothing else Just ("tool_calls" .= toolCalls) @@ -143,16 +181,16 @@ ] userMessage :: Text -> Message -userMessage content = Message { role = UserRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } +userMessage content = Message { role = UserRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [], cacheControl = Nothing } systemMessage :: Text -> Message -systemMessage content = Message { role = SystemRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } +systemMessage content = Message { role = SystemRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [], cacheControl = Nothing } assistantMessage :: Text -> Message -assistantMessage content = Message { role = AssistantRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } +assistantMessage content = Message { role = AssistantRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [], cacheControl = Nothing } toolMessage :: Text -> Message -toolMessage content = Message { role = ToolRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } +toolMessage content = Message { role = ToolRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [], cacheControl = Nothing } newCompletionRequest :: CompletionRequest newCompletionRequest = CompletionRequest @@ -165,6 +203,9 @@ , stream = False , responseFormat = Nothing , tools = [] + , reasoningEffort = Nothing + , parallelToolCalls = Nothing + , extraHeaders = [] } data CompletionResult @@ -198,9 +239,15 @@ content <- deltaOrMessage .: "content" pure Choice { text = content } +data FinishReason + = FinishReasonStop + | FinishReasonLength + | FinishReasonContentFilter + | FinishReasonToolCalls + deriving (Eq, Show) -streamCompletion :: ByteString -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO [CompletionChunk] -streamCompletion secretKey completionRequest' onStart callback = do +streamCompletion :: Config -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO [CompletionChunk] +streamCompletion config completionRequest' onStart callback = do let completionRequest = enableStream completionRequest' completionRequestRef <- newIORef completionRequest result <- Retry.retrying retryPolicyDefault shouldRetry (action completionRequestRef) @@ -215,7 +262,7 @@ action completionRequestRef retryStatus = do completionRequest <- readIORef completionRequestRef let onStart' = if retryStatus.rsIterNumber == 0 then onStart else pure () - Exception.try (streamCompletionWithoutRetry secretKey completionRequest onStart' (wrappedCallback completionRequestRef)) + Exception.try (streamCompletionWithoutRetry config completionRequest onStart' (wrappedCallback completionRequestRef)) wrappedCallback completionRequestRef completionChunk = do let text = mconcat $ Maybe.mapMaybe (\choiceDelta -> choiceDelta.delta.content) completionChunk.choices @@ -230,19 +277,24 @@ retryPolicyDefault = Retry.constantDelay 50000 <> Retry.limitRetries 10 -streamCompletionWithoutRetry :: ByteString -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO (Either Text [CompletionChunk]) -streamCompletionWithoutRetry secretKey completionRequest' onStart callback = do +streamCompletionWithoutRetry :: Config -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO (Either Text [CompletionChunk]) +streamCompletionWithoutRetry Config { .. } completionRequest' onStart callback = do let completionRequest = enableStream completionRequest' modifyContextSSL (\context -> do SSL.contextSetVerificationMode context SSL.VerifyNone pure context ) + let + endpoint = "/chat/completions" + url :: Text = baseUrl <> endpoint + basePath :: ByteString = Text.encodeUtf8 (Text.pack (Maybe.fromMaybe (error "invalid OpenAI baseUrl") ((.uriPath) <$> URI.parseURI (Text.unpack url)))) withOpenSSL do - withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do + withConnection (establishConnection (Text.encodeUtf8 url)) \connection -> do let q = buildRequest1 do - http POST "/v1/chat/completions" + http POST basePath setContentType "application/json" - Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) + Network.Http.Client.setHeader "Authorization" ("Bearer " <> (Text.encodeUtf8 secretKey)) + applyExtraHeaders completionRequest.extraHeaders sendRequest connection q (jsonBody completionRequest) onStart receiveResponse connection handler @@ -261,10 +313,14 @@ state <- Streams.lines stream >>= Streams.foldM (parseResponseChunk' callback) emptyParserState return (Right state.chunks) else do - x :: ByteString <- Streams.fold mappend mempty stream - return (Left $ "an error happend: " <> Text.pack (show x)) + json :: ByteString <- Streams.fold mappend mempty stream + case eitherDecodeStrict json of + Right (CompletionError { message }) -> return (Left message) + Right _ -> error "Should never happen" + Left _ -> return (Left $ "an error happend: " <> Text.pack (show json)) + parseResponseChunk' :: (CompletionChunk -> IO ()) -> ParserState -> ByteString -> IO ParserState parseResponseChunk' callback state input = case parseResponseChunk state input of @@ -315,8 +371,8 @@ , state = ParserState { curBuffer = curBuffer <> input, emptyLineFound = False, chunks = chunks } } -fetchCompletion :: ByteString -> CompletionRequest -> IO Text -fetchCompletion secretKey completionRequest = do +fetchCompletion :: Config -> CompletionRequest -> IO Text +fetchCompletion config completionRequest = do result <- Retry.retrying retryPolicyDefault shouldRetry action case result of Left (e :: SomeException) -> Exception.throwIO e @@ -327,22 +383,27 @@ where shouldRetry retryStatus (Left _) = pure True shouldRetry retryStatus (Right _) = pure False - action retryStatus = Exception.try (fetchCompletionWithoutRetry secretKey completionRequest) + action retryStatus = Exception.try (fetchCompletionWithoutRetry config completionRequest) retryPolicyDefault = Retry.constantDelay 50000 <> Retry.limitRetries 10 -fetchCompletionWithoutRetry :: ByteString -> CompletionRequest -> IO CompletionResult -fetchCompletionWithoutRetry secretKey completionRequest = do +fetchCompletionWithoutRetry :: Config -> CompletionRequest -> IO CompletionResult +fetchCompletionWithoutRetry Config { .. } completionRequest = do + let + endpoint = "/chat/completions" + url :: Text = baseUrl <> endpoint + basePath :: ByteString = Text.encodeUtf8 (Text.pack (Maybe.fromMaybe (error "invalid OpenAI baseUrl") ((.uriPath) <$> URI.parseURI (Text.unpack url)))) modifyContextSSL (\context -> do SSL.contextSetVerificationMode context SSL.VerifyNone pure context ) withOpenSSL do - withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do + withConnection (establishConnection (Text.encodeUtf8 url)) \connection -> do let q = buildRequest1 do - http POST "/v1/chat/completions" + http POST basePath setContentType "application/json" - Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) + Network.Http.Client.setHeader "Authorization" ("Bearer " <> Text.encodeUtf8 secretKey) + applyExtraHeaders completionRequest.extraHeaders sendRequest connection q (jsonBody completionRequest) receiveResponse connection jsonHandler @@ -356,6 +417,7 @@ , created :: Int , model :: !Text , systemFingerprint :: !(Maybe Text) + , usage :: (Maybe Usage) } deriving (Eq, Show) instance FromJSON CompletionChunk where @@ -364,15 +426,17 @@ <*> v .: "choices" <*> v .: "created" <*> v .: "model" - <*> v .: "system_fingerprint" + <*> v .:? "system_fingerprint" + <*> v .:? "usage" data CompletionChunkChoice - = CompletionChunkChoice { delta :: !Delta } + = CompletionChunkChoice { delta :: !Delta, finishReason :: !(Maybe FinishReason) } deriving (Eq, Show) instance FromJSON CompletionChunkChoice where parseJSON = withObject "CompletionChunkChoice" $ \v -> CompletionChunkChoice <$> v .: "delta" + <*> v .: "finish_reason" data Delta = Delta @@ -428,3 +492,31 @@ emptyListToNothing :: [value] -> Maybe [value] emptyListToNothing [] = Nothing emptyListToNothing values = Just values + +instance ToJSON CacheControl where + toJSON Ephemeral = object + [ "type" .= ("ephemeral" :: Text) ] + +data Usage = Usage + { promptTokens :: !Int + , completionTokens :: !Int + , totalTokens :: !Int + } deriving (Eq, Show) + +instance FromJSON Usage where + parseJSON = withObject "Usage" $ \v -> Usage + <$> v .: "prompt_tokens" + <*> v .: "completion_tokens" + <*> v .: "total_tokens" + +applyExtraHeaders extraHeaders = + forM_ extraHeaders \(key, value) -> + Network.Http.Client.setHeader (Text.encodeUtf8 key) (Text.encodeUtf8 value) + + +instance FromJSON FinishReason where + parseJSON (String "stop") = pure FinishReasonStop + parseJSON (String "length") = pure FinishReasonLength + parseJSON (String "content_filter") = pure FinishReasonContentFilter + parseJSON (String "tool_calls") = pure FinishReasonToolCalls + parseJSON otherwise = fail ("Failed to parse finish_reason: " <> show otherwise) diff --git a/Test/IHP/OpenAISpec.hs b/Test/IHP/OpenAISpec.hs --- a/Test/IHP/OpenAISpec.hs +++ b/Test/IHP/OpenAISpec.hs @@ -64,11 +64,13 @@ , toolCalls = Nothing , role = Just AssistantRole } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -79,11 +81,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -94,11 +98,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -109,11 +115,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -124,11 +132,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -139,11 +149,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -154,11 +166,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -169,11 +183,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -184,11 +200,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Nothing } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" @@ -199,11 +217,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Just FinishReasonStop } ] , created = 1715593776 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } ] } @@ -226,11 +246,13 @@ , toolCalls = Just [ FunctionCall { index = 0, id = Just "call_cx6RG7DZq3WlIDfXXp9PdtmS", name = Just "get_current_weather", arguments = "" } ] , role = Just AssistantRole } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } let result = ParserResult { chunk = Just chunk @@ -295,11 +317,13 @@ ] , role = Just AssistantRole } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -317,11 +341,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -339,11 +365,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -361,11 +389,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -383,11 +413,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -405,11 +437,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -427,11 +461,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -449,11 +485,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -471,11 +509,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -493,11 +533,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -515,11 +557,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -537,11 +581,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -559,11 +605,13 @@ ] , role = Nothing } + , finishReason = Nothing } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } , CompletionChunk { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" @@ -574,11 +622,13 @@ , toolCalls = Nothing , role = Nothing } + , finishReason = Just FinishReasonToolCalls } ] , created = 1715277101 , model = "gpt-4-turbo-2024-04-09" , systemFingerprint = Just "fp_294de9593d" + , usage = Nothing } ] } diff --git a/ihp-openai.cabal b/ihp-openai.cabal --- a/ihp-openai.cabal +++ b/ihp-openai.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ihp-openai -version: 1.3.0 +version: 1.4.0 synopsis: Call GPT4 from your Haskell apps description: Streaming functions to access the OpenAI APIs, with Retry and Function Calling license: MIT @@ -17,9 +17,9 @@ location: https://github.com/digitallyinduced/ihp.git library - default-language: Haskell2010 + default-language: GHC2021 build-depends: - base >= 4.17.0 && < 4.20 + base >= 4.17.0 && < 4.22 , text , http-streams , retry @@ -27,6 +27,9 @@ , bytestring , aeson , HsOpenSSL + , network-uri + , attoparsec-aeson + , safe-exceptions default-extensions: OverloadedStrings FlexibleContexts @@ -38,6 +41,7 @@ , BlockArguments , DisambiguateRecordFields , DuplicateRecordFields + , RecordWildCards ghc-options: -fstatic-argument-transformation -funbox-strict-fields @@ -57,7 +61,7 @@ type: exitcode-stdio-1.0 main-is: IHP/OpenAISpec.hs build-depends: - base >= 4.17.0 && < 4.20 + base >= 4.17.0 && < 4.22 , hspec , neat-interpolation , ihp-openai