diff --git a/IHP/OpenAI.hs b/IHP/OpenAI.hs new file mode 100644 --- /dev/null +++ b/IHP/OpenAI.hs @@ -0,0 +1,430 @@ +module IHP.OpenAI where + +import Data.Text (Text) +import Data.ByteString (ByteString) +import Control.Exception (SomeException) +import Data.IORef + +import qualified System.IO.Streams as Streams +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteString +import Network.Http.Client +import Data.Aeson +import OpenSSL +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 Control.Applicative ((<|>)) +import qualified Data.Aeson.Key as Key +import qualified Data.Maybe as Maybe + +data CompletionRequest = CompletionRequest + { messages :: ![Message] + , model :: !Text + , maxTokens :: !(Maybe Int) + , temperature :: !(Maybe Double) + , presencePenalty :: !(Maybe Double) + , frequencePenalty :: !(Maybe Double) + , stream :: !Bool + , responseFormat :: !(Maybe ResponseFormat) + , tools :: ![Tool] + } deriving (Eq, Show) + +data Message = Message + { role :: !Role + , content :: !Text + , name :: !(Maybe Text) + , toolCallId :: !(Maybe Text) + , toolCalls :: ![ToolCall] + } deriving (Eq, Show) + +data Role + = UserRole + | SystemRole + | AssistantRole + | ToolRole + deriving (Eq, Show) + +data ResponseFormat + = Text + | JsonObject + deriving (Eq, Show) + +data Tool + = Function { description :: !(Maybe Text), name :: !Text, parameters :: !(Maybe JsonSchema) } + deriving (Eq, Show) + +data JsonSchema + = JsonSchemaObject ![Property] + | JsonSchemaString + | JsonSchemaInteger + | JsonSchemaNumber + | JsonSchemaArray !JsonSchema + | JsonSchemaEnum ![Text] + deriving (Eq, Show) + +data Property + = Property { propertyName :: !Text, type_ :: !JsonSchema, required :: !Bool, description :: !(Maybe Text) } + 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 + ] + +instance ToJSON Role where + toJSON UserRole = toJSON ("user" :: Text) + toJSON SystemRole = toJSON ("system" :: Text) + toJSON AssistantRole = toJSON ("assistant" :: Text) + toJSON ToolRole = toJSON ("tool" :: Text) + +instance ToJSON Message where + toJSON Message { role, content, name, toolCallId, toolCalls } = object $ Maybe.catMaybes + [ Just ("role" .= role) + , Just ("content" .= content) + , ("name" .=) <$> name + , ("tool_call_id" .=) <$> toolCallId + , if null toolCalls then Nothing else Just ("tool_calls" .= toolCalls) + ] + +instance ToJSON ResponseFormat where + toJSON Text = object [ "type" .= ("text" :: Text) ] + toJSON JsonObject = object [ "type" .= ("json_object" :: Text) ] + +instance ToJSON Tool where + toJSON Function { description, name, parameters } = + object + [ "type" .= ("function" :: Text) + , "function" .= (object + [ "name" .= name + , "description" .= description + , "parameters" .= parameters + ]) + ] + +instance ToJSON JsonSchema where + toJSON (JsonSchemaObject properties) = + object + [ "type" .= ("object" :: Text) + , "properties" .= (object (concat (map (\property -> [ (Key.fromText property.propertyName) .= ((toJSON property.type_) `mergeObj` (object $ Maybe.catMaybes [ ("description" .=) <$> property.description ])) ]) properties))) + ] + where + mergeObj (Object first) (Object second) = Object (first <> second) + mergeObj _ _ = error "JsonSchema.mergeObj failed with invalid type" + toJSON JsonSchemaString = + object [ "type" .= ("string" :: Text) ] + + toJSON JsonSchemaInteger = + object [ "type" .= ("integer" :: Text) ] + + toJSON JsonSchemaNumber = + object [ "type" .= ("number" :: Text) ] + + toJSON (JsonSchemaArray items) = + object + [ "type" .= ("array" :: Text) + , "items" .= items + ] + + toJSON (JsonSchemaEnum values) = + object + [ "type" .= ("string" :: Text) + , "enum" .= values + ] + +userMessage :: Text -> Message +userMessage content = Message { role = UserRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } + +systemMessage :: Text -> Message +systemMessage content = Message { role = SystemRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } + +assistantMessage :: Text -> Message +assistantMessage content = Message { role = AssistantRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } + +toolMessage :: Text -> Message +toolMessage content = Message { role = ToolRole, content, name = Nothing, toolCallId = Nothing, toolCalls = [] } + +newCompletionRequest :: CompletionRequest +newCompletionRequest = CompletionRequest + { messages = [] + , maxTokens = Nothing + , temperature = Nothing + , presencePenalty = Nothing + , frequencePenalty = Nothing + , model = "gpt-3.5-turbo" + , stream = False + , responseFormat = Nothing + , tools = [] + } + +data CompletionResult + = CompletionResult + { choices :: [Choice] + } + | CompletionError + { message :: !Text + } + deriving (Eq, Show) + +instance FromJSON CompletionResult where + parseJSON = withObject "CompletionResult" \v -> do + let result = CompletionResult <$> v .: "choices" + let error = do + errorObj <- v .: "error" + message <- errorObj .: "message" + pure CompletionError { message } + + result <|> error + +-- [{"text": "Introdu", "index": 0, "logprobs": null, "finish_reason": null}] +data Choice = Choice + { text :: !Text + } + deriving (Eq, Show) + +instance FromJSON Choice where + parseJSON = withObject "Choice" $ \v -> do + deltaOrMessage <- (v .: "message") <|> (v .: "delta") + content <- deltaOrMessage .: "content" + pure Choice { text = content } + + +streamCompletion :: ByteString -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO [CompletionChunk] +streamCompletion secretKey completionRequest' onStart callback = do + let completionRequest = enableStream completionRequest' + completionRequestRef <- newIORef completionRequest + result <- Retry.retrying retryPolicyDefault shouldRetry (action completionRequestRef) + case result of + Left (e :: SomeException) -> Exception.throwIO e + Right (Left e) -> error (Text.unpack e) + Right (Right r) -> pure r + where + shouldRetry retryStatus (Left e) = pure True + shouldRetry retryStatus (Right (Left _)) = pure True + shouldRetry retryStatus (Right (Right r)) = pure False + 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)) + + wrappedCallback completionRequestRef completionChunk = do + let text = mconcat $ Maybe.mapMaybe (\choiceDelta -> choiceDelta.delta.content) completionChunk.choices + modifyIORef' completionRequestRef (\completionRequest -> completionRequest + { messages = completionRequest.messages <> [assistantMessage text] + , maxTokens = case completionRequest.maxTokens of + Just maxTokens -> Just $ maxTokens - (length (Text.words text)) + Nothing -> Nothing + } + ) + callback completionChunk + + retryPolicyDefault = Retry.constantDelay 50000 <> Retry.limitRetries 10 + +streamCompletionWithoutRetry :: ByteString -> CompletionRequest -> IO () -> (CompletionChunk -> IO ()) -> IO (Either Text [CompletionChunk]) +streamCompletionWithoutRetry secretKey completionRequest' onStart callback = do + let completionRequest = enableStream completionRequest' + modifyContextSSL (\context -> do + SSL.contextSetVerificationMode context SSL.VerifyNone + pure context + ) + withOpenSSL do + withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do + let q = buildRequest1 do + http POST "/v1/chat/completions" + setContentType "application/json" + Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) + sendRequest connection q (jsonBody completionRequest) + onStart + receiveResponse connection handler + + where + handler :: Response -> Streams.InputStream ByteString -> IO (Either Text [CompletionChunk]) + handler response stream = do + let status = getStatusCode response + if status == 200 + then do + {- + parse stream line by line as event stream format according to API spec: + https://platform.openai.com/docs/api-reference/chat/create#chat/create-stream + https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events#event_stream_format + -} + 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)) + + + parseResponseChunk' :: (CompletionChunk -> IO ()) -> ParserState -> ByteString -> IO ParserState + parseResponseChunk' callback state input = + case parseResponseChunk state input of + ParserResult { chunk = Just chunk, state } -> do + callback chunk + pure state + ParserResult { state } -> pure state + +data ParserState = ParserState + { curBuffer :: !ByteString + , emptyLineFound :: !Bool + , chunks :: ![CompletionChunk] + } deriving (Eq, Show) +data ParserResult = ParserResult + { chunk :: !(Maybe CompletionChunk) + , state :: ParserState + } deriving (Eq, Show) +emptyParserState :: ParserState +emptyParserState = ParserState { curBuffer = "", emptyLineFound = False, chunks = [] } + +parseResponseChunk :: ParserState -> ByteString -> ParserResult +parseResponseChunk ParserState { curBuffer, emptyLineFound, chunks } input + -- input line is empty, but previous was not, append newline to buffer + | ByteString.null input && not emptyLineFound = ParserResult { chunk = Nothing, state = ParserState { curBuffer = curBuffer <> "\n", emptyLineFound = True, chunks } } + -- input line is empty, previous line was already empty: message ended, clear buffer + | ByteString.null input && emptyLineFound = ParserResult { chunk = Nothing, state = ParserState { curBuffer = "", emptyLineFound = True, chunks } } + -- lines starting with : are comments, ignore + | ":" `ByteString.isPrefixOf` input = ParserResult { chunk = Nothing, state = ParserState { curBuffer = curBuffer, emptyLineFound = False, chunks } } + -- try to parse line together with buffer otherwise + | otherwise = case ByteString.stripPrefix "data: " (ByteString.strip (curBuffer <> input)) of + -- the stream terminated by a data: [DONE] message + Just "[DONE]" -> + ParserResult { chunk = Nothing, state = ParserState { curBuffer, emptyLineFound, chunks } } + Just json -> + case eitherDecodeStrict json of + Right (completionChunk :: CompletionChunk) -> + ParserResult + { chunk = Just completionChunk + , state = ParserState { curBuffer = "", emptyLineFound = False, chunks = chunks <> [completionChunk] } + } + Left err -> error (show err <> " while parsing " <> show input) + --ParserResult + -- { chunk = Nothing + -- , state = ParserState { curBuffer = curBuffer <> json, emptyLineFound = False, chunks = chunks } } + Nothing -> + ParserResult + { chunk = Nothing + , state = ParserState { curBuffer = curBuffer <> input, emptyLineFound = False, chunks = chunks } } + + +fetchCompletion :: ByteString -> CompletionRequest -> IO Text +fetchCompletion secretKey completionRequest = do + result <- Retry.retrying retryPolicyDefault shouldRetry action + case result of + Left (e :: SomeException) -> Exception.throwIO e + Right result -> + case result of + CompletionResult { choices } -> pure (mconcat $ map (.text) choices) + CompletionError { message } -> error (Text.unpack message) + where + shouldRetry retryStatus (Left _) = pure True + shouldRetry retryStatus (Right _) = pure False + action retryStatus = Exception.try (fetchCompletionWithoutRetry secretKey completionRequest) + + retryPolicyDefault = Retry.constantDelay 50000 <> Retry.limitRetries 10 + +fetchCompletionWithoutRetry :: ByteString -> CompletionRequest -> IO CompletionResult +fetchCompletionWithoutRetry secretKey completionRequest = do + modifyContextSSL (\context -> do + SSL.contextSetVerificationMode context SSL.VerifyNone + pure context + ) + withOpenSSL do + withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do + let q = buildRequest1 do + http POST "/v1/chat/completions" + setContentType "application/json" + Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) + + sendRequest connection q (jsonBody completionRequest) + receiveResponse connection jsonHandler + +enableStream :: CompletionRequest -> CompletionRequest +enableStream completionRequest = completionRequest { stream = True } + +data CompletionChunk = CompletionChunk + { id :: !Text + , choices :: [CompletionChunkChoice] + , created :: Int + , model :: !Text + , systemFingerprint :: !(Maybe Text) + } deriving (Eq, Show) + +instance FromJSON CompletionChunk where + parseJSON = withObject "CompletionChunk" $ \v -> CompletionChunk + <$> v .: "id" + <*> v .: "choices" + <*> v .: "created" + <*> v .: "model" + <*> v .: "system_fingerprint" + +data CompletionChunkChoice + = CompletionChunkChoice { delta :: !Delta } + deriving (Eq, Show) + +instance FromJSON CompletionChunkChoice where + parseJSON = withObject "CompletionChunkChoice" $ \v -> CompletionChunkChoice + <$> v .: "delta" + +data Delta + = Delta + { content :: !(Maybe Text) + , toolCalls :: !(Maybe [ToolCall]) + , role :: !(Maybe Role) + } deriving (Eq, Show) + +instance FromJSON Delta where + parseJSON = withObject "Delta" $ \v -> Delta + <$> v .:? "content" + <*> v .:? "tool_calls" + <*> v .:? "role" + +instance FromJSON Role where + parseJSON (String "user") = pure UserRole + parseJSON (String "system") = pure SystemRole + parseJSON (String "assistant") = pure AssistantRole + parseJSON (String "ToolRole") = pure ToolRole + parseJSON otherwise = fail ("Failed to parse role" <> show otherwise) + +data ToolCall + = FunctionCall + { index :: !Int + , id :: !(Maybe Text) + , name :: !(Maybe Text) + , arguments :: !Text + } deriving (Eq, Show) + +instance FromJSON ToolCall where + parseJSON = withObject "ToolCall" $ \v -> do + index <- v .: "index" + id <- v .:? "id" + + function <- v .: "function" + name <- function .:? "name" + arguments <- function .: "arguments" + + pure FunctionCall { index, id, name, arguments } + +instance ToJSON ToolCall where + toJSON FunctionCall { index, id, name, arguments } = + object + [ "index" .= index + , "id" .= id + , "type" .= ("function" :: Text) + , "function" .= object [ "name" .= name, "arguments" .= arguments ] + ] + +-- [{"text": "Introdu", "index": 0, "logprobs": null, "finish_reason": null}] + + +emptyListToNothing :: [value] -> Maybe [value] +emptyListToNothing [] = Nothing +emptyListToNothing values = Just values diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2023 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,117 @@ +# OpenAI + +This `ihp-openai` package provides streaming functions to access GPT3 and GPT4 from OpenAI. + +The package is designed to work well with IHP AutoRefresh and IHP DataSync. The main function `streamCompletion` uses the OpenAI Chat API. It was created before the Chat API was available, and the later rewritten to work well with GPT-4. That's why it feels a bit like a mix of the completion and the chat api. + +API calls are retried up to 10 times. A retry will continue with the already generated output tokens, so that a user will never see that a retry has happend. + +## Install + +1. Make sure you're running on the latest master version of IHP + +2. Open `default.nix` and add `ihp-openai` to your haskell dependencies: + + ```nix + let + ihp = ...; + haskellEnv = import "${ihp}/NixSupport/default.nix" { + ihp = ihp; + haskellDeps = p: with p; [ + cabal-install + base + wai + text + hlint + p.ihp + + ihp-openai + ]; + otherDeps = p: with p; [ + # Native dependencies, e.g. imagemagick + ]; + projectPath = ./.; + }; + in + haskellEnv + + ``` + +## Example + +```haskell +module Web.Controller.Questions where + +import Web.Controller.Prelude +import Web.View.Questions.Index +import Web.View.Questions.New +import Web.View.Questions.Edit +import Web.View.Questions.Show + +import qualified IHP.OpenAI as GPT + +instance Controller QuestionsController where + action QuestionsAction = autoRefresh do + questions <- query @Question + |> orderByDesc #createdAt + |> fetch + render IndexView { .. } + + action NewQuestionAction = do + let question = newRecord + |> set #question "What makes haskell so great?" + render NewView { .. } + + action CreateQuestionAction = do + let question = newRecord @Question + question + |> fill @'["question"] + |> validateField #question nonEmpty + |> ifValid \case + Left question -> render NewView { .. } + Right question -> do + question <- question |> createRecord + setSuccessMessage "Question created" + + fillAnswer question + + redirectTo QuestionsAction + + action DeleteQuestionAction { questionId } = do + question <- fetch questionId + deleteRecord question + setSuccessMessage "Question deleted" + redirectTo QuestionsAction + +fillAnswer :: (?modelContext :: ModelContext) => Question -> IO (Async ()) +fillAnswer question = do + -- Put your OpenAI secret key below: + let secretKey = "sk-XXXXXXXX" + + -- This should be done with an IHP job worker instead of async + async do + GPT.streamCompletion secretKey (buildCompletionRequest question) (clearAnswer question) (appendToken question) + pure () + +buildCompletionRequest :: Question -> GPT.CompletionRequest +buildCompletionRequest Question { question } = + -- Here you can adjust the parameters of the request + GPT.newCompletionRequest + { GPT.maxTokens = 512 + , GPT.prompt = [trimming| + Question: ${question} + Answer: + |] } + +-- | Sets the answer field back to an empty string +clearAnswer :: (?modelContext :: ModelContext) => Question -> IO () +clearAnswer question = do + sqlExec "UPDATE questions SET answer = '' WHERE id = ?" (Only question.id) + pure () + +-- | Stores a couple of newly received characters to the database +appendToken :: (?modelContext :: ModelContext) => Question -> Text -> IO () +appendToken question token = do + sqlExec "UPDATE questions SET answer = answer || ? WHERE id = ?" (token, question.id) + pure () +``` diff --git a/Test/IHP/OpenAISpec.hs b/Test/IHP/OpenAISpec.hs new file mode 100644 --- /dev/null +++ b/Test/IHP/OpenAISpec.hs @@ -0,0 +1,653 @@ +module Main where + +import Test.Hspec +import IHP.OpenAI +import NeatInterpolation (trimming) +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import Data.Aeson + +main :: IO () +main = hspec do + tests + +tests = do + describe "IHP.OpenAI" do + describe "parseResponseChunk" do + it "should parse a simple message response 'What's 1 + 2?'" do + -- curl https://api.openai.com/v1/chat/completions \ + -- -H "Content-Type: application/json" \ + -- -H "Authorization: Bearer $OPENAI_TOKEN" \ + -- -d '{ + -- "model": "gpt-4-turbo", + -- "stream": true, + -- "messages": [ + -- { + -- "role": "user", + -- "content": "What 1 + 2?" + -- } + -- ] + -- }' + let input = [trimming| + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"role":"assistant","content":""},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":"1"},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":" +"},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":" "},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":"2"},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":" equals"},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":" "},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":"3"},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"content":"."},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI","object":"chat.completion.chunk","created":1715593776,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{},"logprobs":null,"finish_reason":"stop"}]} + + data: [DONE] + |] + let result = ParserState + { curBuffer = "\n" + , emptyLineFound = True + , chunks = + [ CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just "" + , toolCalls = Nothing + , role = Just AssistantRole + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just "1" + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just " +" + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just " " + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just "2" + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just " equals" + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just " " + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just "3" + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Just "." + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9OMbIk2dtKfDVvDUNgi8ARVSC4LmI" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715593776 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + ] + } + + + let parseLines = foldl (\state line -> (parseResponseChunk state (Text.encodeUtf8 line)).state) emptyParserState (Text.lines input) + + parseLines `shouldBe` result + + it "should parse a line with a function call" do + let input = Text.encodeUtf8 [trimming| + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"role":"assistant","content":null,"tool_calls":[{"index":0,"id":"call_cx6RG7DZq3WlIDfXXp9PdtmS","type":"function","function":{"name":"get_current_weather","arguments":""}}]},"logprobs":null,"finish_reason":null}]} + |] + let chunk = CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just [ FunctionCall { index = 0, id = Just "call_cx6RG7DZq3WlIDfXXp9PdtmS", name = Just "get_current_weather", arguments = "" } ] + , role = Just AssistantRole + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + let result = ParserResult + { chunk = Just chunk + , state = ParserState + { curBuffer = "" + , emptyLineFound = False + , chunks = [chunk] + } + } + parseResponseChunk emptyParserState input `shouldBe` result + + + it "should parse a full tool call with arguments" do + let input = [trimming| + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"role":"assistant","content":null,"tool_calls":[{"index":0,"id":"call_cx6RG7DZq3WlIDfXXp9PdtmS","type":"function","function":{"name":"get_current_weather","arguments":""}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"{\""}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"location"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"\":\""}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"Boston"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":","}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":" MA"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"\",\""}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"unit"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"\":\""}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"f"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"ahrenheit"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{"tool_calls":[{"index":0,"function":{"arguments":"\"}"}}]},"logprobs":null,"finish_reason":null}]} + + data: {"id":"chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o","object":"chat.completion.chunk","created":1715277101,"model":"gpt-4-turbo-2024-04-09","system_fingerprint":"fp_294de9593d","choices":[{"index":0,"delta":{},"logprobs":null,"finish_reason":"tool_calls"}]} + + data: [DONE] + |] + let result = ParserState + { curBuffer = "\n" + , emptyLineFound = True + , chunks = + [ CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Just "call_cx6RG7DZq3WlIDfXXp9PdtmS" + , name = Just "get_current_weather" + , arguments = "" + } + ] + , role = Just AssistantRole + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "{\"" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "location" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "\":\"" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "Boston" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "," + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = " MA" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "\",\"" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "unit" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "\":\"" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "f" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "ahrenheit" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Just + [ FunctionCall + { index = 0 + , id = Nothing + , name = Nothing + , arguments = "\"}" + } + ] + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + , CompletionChunk + { id = "chatcmpl-9N2DdAg2usc3V0VoinTcCwv5rBs3o" + , choices = + [ CompletionChunkChoice + { delta = Delta + { content = Nothing + , toolCalls = Nothing + , role = Nothing + } + } + ] + , created = 1715277101 + , model = "gpt-4-turbo-2024-04-09" + , systemFingerprint = Just "fp_294de9593d" + } + ] + } + + let parseLines = foldl (\state line -> (parseResponseChunk state (Text.encodeUtf8 line)).state) emptyParserState (Text.lines input) + + parseLines `shouldBe` result + + describe "ToJSON Tool" do + it "encode Function call with parameter descriptions" do + let function = Function + { name = "fetchUrl" + , description = Just "Fetches a url" + , parameters = Just (JsonSchemaObject [ Property { propertyName = "url", type_ = JsonSchemaString, required = True, description = Just "The url to fetch" }]) + } + + encode function `shouldBe` "{\"function\":{\"description\":\"Fetches a url\",\"name\":\"fetchUrl\",\"parameters\":{\"properties\":{\"url\":{\"description\":\"The url to fetch\",\"type\":\"string\"}},\"type\":\"object\"}},\"type\":\"function\"}" + + describe "ToJSON Message" do + it "encode a message but only set fields that are not null" do + let message = userMessage "" + + encode message `shouldBe` "{\"content\":\"\",\"role\":\"user\"}" + + describe "ToJSON JsonSchema" do + it "not render null description's for object properties" do + let object = JsonSchemaObject [Property { propertyName = "a", type_ = JsonSchemaString, required = True, description = Nothing } ] + + encode object `shouldBe` "{\"properties\":{\"a\":{\"type\":\"string\"}},\"type\":\"object\"}" + + describe "FromJSON CompletionResult" do + it "should decode a successful response" do + let response = [trimming| + { + "id": "chatcmpl-abc123", + "object": "chat.completion", + "created": 1677858242, + "model": "gpt-3.5-turbo-0613", + "usage": { + "prompt_tokens": 13, + "completion_tokens": 7, + "total_tokens": 20 + }, + "choices": [ + { + "message": { + "role": "assistant", + "content": "\n\nThis is a test!" + }, + "logprobs": null, + "finish_reason": "stop", + "index": 0 + } + ] + } + |] + + decodeStrictText (response) `shouldBe` (Just CompletionResult { choices = [ Choice { text = "\n\nThis is a test!" } ] }) + + it "should decode an error response" do + let response = [trimming| + { + "error": { + "message": "You exceeded your current quota, please check your plan and billing details. For more information on this error, read the docs: https://platform.openai.com/docs/guides/error-codes/api-errors.", + "type": "insufficient_quota", + "param": null, + "code": "insufficient_quota" + } + } + |] + + decodeStrictText (response) `shouldBe` (Just CompletionError { message = "You exceeded your current quota, please check your plan and billing details. For more information on this error, read the docs: https://platform.openai.com/docs/guides/error-codes/api-errors." }) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,5 @@ +# Changelog for `ihp-openai` + +## v1.3 + +- This is the initial hackage release diff --git a/ihp-openai.cabal b/ihp-openai.cabal new file mode 100644 --- /dev/null +++ b/ihp-openai.cabal @@ -0,0 +1,79 @@ +cabal-version: 2.2 +name: ihp-openai +version: 1.3.0 +synopsis: Call GPT4 from your Haskell apps +description: Streaming functions to access the OpenAI APIs, with Retry and Function Calling +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: support@digitallyinduced.com +bug-reports: https://github.com/digitallyinduced/ihp/issues +category: AI +build-type: Simple +extra-source-files: README.md, changelog.md + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp.git + +library + default-language: Haskell2010 + build-depends: + base >= 4.17.0 && < 4.20 + , text + , http-streams + , retry + , io-streams + , bytestring + , aeson + , HsOpenSSL + default-extensions: + OverloadedStrings + FlexibleContexts + , ScopedTypeVariables + , NamedFieldPuns + , BangPatterns + , BlockArguments + , OverloadedRecordDot + , BlockArguments + , DisambiguateRecordFields + , DuplicateRecordFields + ghc-options: + -fstatic-argument-transformation + -funbox-strict-fields + -haddock + -Wredundant-constraints + -Wunused-imports + -Wunused-foralls + -Wmissing-fields + -Winaccessible-code + -Wmissed-specialisations + -fexpose-all-unfoldings + hs-source-dirs: . + exposed-modules: + IHP.OpenAI + +test-suite tests + type: exitcode-stdio-1.0 + main-is: IHP/OpenAISpec.hs + build-depends: + base >= 4.17.0 && < 4.20 + , hspec + , neat-interpolation + , ihp-openai + , text + , aeson + hs-source-dirs: Test + default-language: Haskell2010 + default-extensions: + OverloadedStrings + FlexibleContexts + , ScopedTypeVariables + , NamedFieldPuns + , BangPatterns + , BlockArguments + , OverloadedRecordDot + , BlockArguments + , DisambiguateRecordFields + , DuplicateRecordFields + , QuasiQuotes