ihp-openai 1.3.0 → 1.4.0
raw patch · 3 files changed
+188/−42 lines, 3 filesdep +attoparsec-aesondep +network-uridep +safe-exceptionsdep ~base
Dependencies added: attoparsec-aeson, network-uri, safe-exceptions
Dependency ranges changed: base
Files
- IHP/OpenAI.hs +130/−38
- Test/IHP/OpenAISpec.hs +50/−0
- ihp-openai.cabal +8/−4
IHP/OpenAI.hs view
@@ -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)
Test/IHP/OpenAISpec.hs view
@@ -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 } ] }
ihp-openai.cabal view
@@ -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