diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for agentic-openai + +## 0.2.0.0 - 2026-10-01 + +First release of the v2 design. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2026, Tom Wells + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/agentic-openai.cabal b/agentic-openai.cabal new file mode 100644 --- /dev/null +++ b/agentic-openai.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: agentic-openai +version: 0.2.0.0 +synopsis: OpenAI as the System Two provider for agentic +description: + Runs agentic's draft steps on OpenAI models through the Responses API, with strict structured outputs and tools, and can stand in as System One. +license: BSD-2-Clause +license-file: LICENSE +author: Tom Wells +maintainer: drshade@gmail.com +copyright: 2026 Tom Wells +category: AI +homepage: https://github.com/drshade/haskell-agentic +bug-reports: https://github.com/drshade/haskell-agentic/issues +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1 + +source-repository head + type: git + location: https://github.com/drshade/haskell-agentic.git + subdir: agentic-openai + +common shared + default-language: GHC2021 + default-extensions: + DeriveAnyClass + DerivingVia + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall + +library + import: shared + hs-source-dirs: src + exposed-modules: Agentic.OpenAI + build-depends: + , agentic ==0.2.* + , agentic-aeson ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , http-client >=0.7 && <0.8 + , http-client-tls >=0.3 && <0.4 + , http-types >=0.12 && <0.13 + , text >=2.0 && <2.2 +test-suite agentic-openai-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + , agentic ==0.2.* + , agentic-aeson ==0.2.* + , agentic-openai ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 +-- Calls the real API. Pending unless OPENAI_API_KEY is set (in the environment or .env). +test-suite agentic-openai-live + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test-live + main-is: Live.hs + build-depends: + , agentic ==0.2.* + , agentic-openai ==0.2.* + , agentic-io ==0.2.* + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 diff --git a/src/Agentic/OpenAI.hs b/src/Agentic/OpenAI.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/OpenAI.hs @@ -0,0 +1,248 @@ +-- | OpenAI as a runtime's System Two (and, through 'viaLLM', System One), over +-- the Responses API. +-- +-- > rt <- pure runtime >>= withSystemTwo openai +-- > rt <- pure runtime >>= withSystemTwo (openai & model "gpt-6.1-sol" & effort Low) +module Agentic.OpenAI + ( OpenAI (..) + , openai + , OpenAIError (..) + -- * Wire format + , requestBody + , decodeTurn + ) where + +import Agentic.Aeson (fromAeson) +import Agentic.Core (Instruction (..)) +import Agentic.JsonSchema (objectSchema, schemaName, unwrap) +import Agentic.Runtime +import Agentic.Schema (Schema) +import Agentic.Settings +import qualified Agentic.Value as A +import Agentic.ViaLLM (viaLLM) +import Control.Exception (Exception (..), throwIO) +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Network.HTTP.Client as Http +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types.Status (statusCode) +import System.Environment (lookupEnv) + +-- | OpenAI's settings. Start from 'openai' and change them with the setters +-- from "Agentic.Settings": 'Agentic.Settings.model', 'Agentic.Settings.system', +-- 'Agentic.Settings.effort', 'Agentic.Settings.maxTokens', 'Agentic.Settings.key', +-- 'Agentic.Settings.endpoint' and 'Agentic.Settings.timeout'. +data OpenAI = OpenAI + { model :: Text + , system :: Maybe Text + -- ^ Sent as the request's instructions. + , maxTokens :: Maybe Int + , effort :: Maybe Effort + -- ^ The model's default if unset. + , key :: Maybe Text + -- ^ Defaults to the @OPENAI_API_KEY@ environment variable. + , endpoint :: String + , timeout :: Int + -- ^ Seconds. + } + +openai :: OpenAI +openai = + OpenAI + { model = "gpt-6-astra" + , system = Nothing + , maxTokens = Nothing + , effort = Nothing + , key = Nothing + , endpoint = "https://api.openai.com/v1/responses" + , timeout = 600 + } + +instance HasModel OpenAI where model m c = c {model = m} +instance HasSystem OpenAI where system t c = c {system = Just t} +instance HasMaxTokens OpenAI where maxTokens n c = c {maxTokens = Just n} +instance HasEffort OpenAI where effort e c = c {effort = Just e} +instance HasKey OpenAI where key k c = c {key = Just k} +instance HasEndpoint OpenAI where endpoint e c = c {endpoint = e} +instance HasTimeout OpenAI where timeout t c = c {timeout = t} + +effortName :: Effort -> Text +effortName = \case + Low -> "low" + Medium -> "medium" + High -> "high" + XHigh -> "xhigh" + Max -> "max" + +-- | What can go wrong talking to the Responses API. Thrown in IO. +data OpenAIError + = MissingKey + | HttpError Int Text + -- ^ A non-200 status, and the API's error body. + | Refused Text + -- ^ The model refused, with its explanation. + | Truncated + -- ^ The reply hit the token limit before it was complete. + | Incomplete Text + -- ^ The response stopped early for another reason. + | UnexpectedResponse Text + deriving (Show) + +instance Exception OpenAIError where + displayException = \case + MissingKey -> "OpenAI: no API key. Set OPENAI_API_KEY, or use (openai & key ...)." + HttpError status body -> "OpenAI rejected the request (HTTP " <> show status <> "): " <> T.unpack body + Refused why -> "The model refused: " <> T.unpack why + Truncated -> "The reply hit the token limit; raise it with (openai & maxTokens ...)" + Incomplete reason -> "The response stopped early: " <> T.unpack reason + UnexpectedResponse problem -> "OpenAI sent a response agentic can't read: " <> T.unpack problem + +instance ProvidesSystemTwo OpenAI where + toSystemTwo cfg = do + key' <- maybe (fmap T.pack <$> lookupEnv "OPENAI_API_KEY") (pure . Just) cfg.key >>= maybe (throwIO MissingKey) pure + manager <- newTlsManager + base <- Http.parseRequest cfg.endpoint + pure $ SystemTwo $ \conversation -> do + let http = + base + { Http.method = "POST" + , Http.requestHeaders = + [ ("Authorization", "Bearer " <> T.encodeUtf8 key') + , ("Content-Type", "application/json") + ] + , Http.requestBody = Http.RequestBodyLBS (TL.encodeUtf8 (TL.fromStrict (A.renderJson (requestBody cfg conversation)))) + , Http.responseTimeout = Http.responseTimeoutMicro (cfg.timeout * 1000000) + } + response <- Http.httpLbs http manager + let status = statusCode (Http.responseStatus response) + body = Http.responseBody response + if status /= 200 + then throwIO (HttpError status (T.decodeUtf8Lenient (LBS.toStrict body))) + else case J.eitherDecode body of + Left problem -> throwIO (UnexpectedResponse (T.pack problem)) + Right value -> either throwIO pure (decodeTurn conversation value) + +-- | The model answers judgements too, with uncalibrated probabilities. +instance ProvidesSystemOne OpenAI where + toSystemOne cfg = viaLLM <$> toSystemTwo cfg + +-- | The Responses API request for one turn of a step. Nothing is stored on +-- OpenAI's side: each turn sends the whole step so far, and reasoning comes +-- back encrypted so it can be sent back unchanged. +requestBody :: OpenAI -> Conversation -> A.Value +requestBody cfg c = + A.Object $ + [("model", A.String cfg.model)] + <> maybe [] (\s -> [("instructions", A.String s)]) cfg.system + <> [("tools", A.Array (map tool (tools c))) | not (null (tools c))] + <> [ ("input", A.Array (task : concatMap exchange (history c))) + , ( "text" + , A.Object + [ ( "format" + , A.Object + [ ("type", A.String "json_schema") + , ("name", A.String (schemaName (output c))) + , ("schema", objectSchema (output c)) + , ("strict", A.Bool True) + ] + ) + ] + ) + , ("store", A.Bool False) + , ("include", A.Array [A.String "reasoning.encrypted_content"]) + ] + <> maybe [] (\e -> [("reasoning", A.Object [("effort", A.String (effortName e))])]) cfg.effort + <> maybe [] (\n -> [("max_output_tokens", A.Integer (toInteger n))]) cfg.maxTokens + where + task = message "user" (instructionText (instruction c) <> input) + input = case state c of + A.Null -> "" + s -> "\n\nInput:\n" <> A.renderJson s + tool spec = + A.Object + [ ("type", A.String "function") + , ("name", A.String (specName spec)) + , ("description", A.String (specDescription spec)) + , ("parameters", objectSchema (specInput spec)) + , ("strict", A.Bool True) + ] + -- A turn's raw value is its list of output items, which go back as input. + items (Raw raw) = case raw of + A.Array xs -> xs + other -> [other] + exchange = \case + Called raw results -> items raw <> map result results + Rejected raw problem -> items raw <> [message "user" ("That answer was rejected: " <> problem <> ". Please answer again.")] + result (callId', r) = + A.Object + [ ("type", A.String "function_call_output") + , ("call_id", A.String callId') + , ("output", A.String (case r of ToolOk v -> asText v; ToolFailed problem -> "Error: " <> problem)) + ] + asText = \case + A.String t -> t + v -> A.renderJson v + message :: Text -> Text -> A.Value + message role content = A.Object [("role", A.String role), ("content", A.String content)] + +-- | Read one turn from a Responses API response. +decodeTurn :: Conversation -> J.Value -> Either OpenAIError Turn +decodeTurn c = either (Left . UnexpectedResponse . T.pack) id . J.parseEither parse + where + parse = J.withObject "response" $ \r -> do + status <- r .: "status" + details <- r .:? "incomplete_details" + reason <- maybe (pure Nothing) (J.withObject "incomplete_details" (.:? "reason")) details + outputs <- r .: "output" :: J.Parser [J.Value] + -- Message parts are flattened into the item list. + parsed <- concatMap (\case Message parts -> parts; x -> [x]) <$> traverse item outputs + let raw = Raw (fromAeson (J.toJSON outputs)) + calls = [ToolCall i n (unwrapInput n v) | Call i n v <- parsed] + text = T.concat [t | Text t <- parsed] + refusals = [t | Refusal t <- parsed] + pure $ case (status :: Text, reason :: Maybe Text) of + (_, _) | why : _ <- refusals -> Left (Refused why) + ("incomplete", Just "max_output_tokens") -> Left Truncated + ("incomplete", Just "content_filter") -> Left (Refused "content filter") + ("incomplete", other) -> Left (Incomplete (maybe "unknown" id other)) + ("completed", _) + | not (null calls) -> Right (Turn raw (CallTools calls)) + | otherwise -> Right (Turn raw (Respond (final text))) + (other, _) -> Left (Incomplete other) + item = J.withObject "item" $ \o -> do + kind <- o .: "type" + case kind :: Text of + "function_call" -> do + arguments <- o .: "arguments" + Call <$> o .: "call_id" <*> o .: "name" <*> pure (json arguments) + "message" -> do + content <- o .: "content" + Message <$> traverse part content + _ -> pure Other + part = J.withObject "part" $ \p -> do + kind <- p .: "type" + case kind :: Text of + "output_text" -> Text <$> p .: "text" + "refusal" -> Refusal <$> p .: "refusal" + _ -> pure Other + -- A reply that isn't JSON goes back to the core as text; the output + -- contract then rejects it and the model gets another go. + final text = case decodeJson text of + Just v -> unwrap (output c) v + Nothing -> A.String text + json t = maybe (A.String t) id (decodeJson t) + decodeJson t = fromAeson <$> J.decode (TL.encodeUtf8 (TL.fromStrict t)) + unwrapInput name v = maybe v (`unwrap` v) (inputSchema name) + inputSchema :: Text -> Maybe Schema + inputSchema name = case [specInput s | s <- tools c, specName s == name] of + s : _ -> Just s + [] -> Nothing + +data Item = Call Text Text A.Value | Message [Item] | Text Text | Refusal Text | Other diff --git a/test-live/Live.hs b/test-live/Live.hs new file mode 100644 --- /dev/null +++ b/test-live/Live.hs @@ -0,0 +1,89 @@ +module Main (main) where + +import Agentic +import Agentic.OpenAI (openai) +import Agentic.IO.DotEnv (loadDotEnv) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Environment (lookupEnv) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Joke = Joke {genre :: Text, setup :: Text, punchline :: Text} + deriving (Generic, Show, Contract) + +data BetterJoke + = DadJoke {setup' :: Text, punchline' :: Text} + | OneLiner {line :: Text} + | KnockKnock {whosThere :: Text, punchline' :: Text} + deriving (Generic, Show, Contract) + +data Groan = Mild | Solid | Unbearable + deriving (Generic, Show, Eq) + +instance Options Groan where + options = + described + "How much the audience groans" + [option Mild "A polite smile", option Solid "An audible groan", option Unbearable "People get up and leave"] + +deriving via Enumeration Groan instance Contract Groan + +newtype Rating = Rating Int + deriving (Show, Eq) + +instance Contract Rating where + contract = mapCodec Rating (\(Rating n) -> n) (between 1 10 contract) + +main :: IO () +main = do + _ <- loadDotEnv + apiKey <- lookupEnv "OPENAI_API_KEY" + hspec $ Test.Hspec.describe "OpenAI, live" $ case apiKey of + Nothing -> it "needs OPENAI_API_KEY" (pendingWith "set OPENAI_API_KEY in .env to run the live tests") + Just _ -> do + let fast = openai & effort Low + withModel = pure runtime >>= withSystemTwo fast + + it "drafts a record" $ do + rt <- withModel + j <- interpret rt (draft @Joke "a joke please") () + T.null j.punchline `shouldBe` False + + it "drafts a list, which has to be wrapped for structured outputs" $ do + rt <- withModel + names <- interpret rt (draft @[Text] "Name exactly 3 dinosaurs") () + length names `shouldBe` 3 + + it "drafts a sum type from typed input" $ do + rt <- withModel + j <- interpret rt (draft @BetterJoke "Convert this knock-knock joke") (Joke "knock-knock" "Knock knock. Who's there? Boo." "Don't cry, it's only a joke!") + case j of + KnockKnock {} -> pure () + other -> expectationFailure ("expected a KnockKnock, got " <> show other) + + it "runs a tool loop" $ do + calls <- newIORef (0 :: Int) + let lookupFossil = tool @Text @Text "fossil_count" "How many fossils the museum holds of a dinosaur" $ + act (\_ -> modifyIORef calls (+ 1) >> pure "The museum holds 17 fossils of it.") + rt <- withModel + n <- interpret rt (draftWith @Int [lookupFossil] "How many Stegosaurus fossils does the museum hold? Use the tool.") () + n `shouldBe` 17 + readIORef calls >>= (`shouldSatisfy` (>= 1)) + + it "keeps within a contract's checks" $ do + rt <- withModel + Rating n <- interpret rt (draft @Rating "Rate this joke") (Joke "pun" "Why was the scarecrow promoted?" "He was outstanding in his field.") + n `shouldSatisfy` (\x -> x >= 1 && x <= 10) + + it "drafts an Options type, whose schema is described constants" $ do + rt <- withModel + g <- interpret rt (draft @Groan "How much will the audience groan at this pun?") ("I'm reading a book about anti-gravity. It's impossible to put down." :: Text) + g `shouldSatisfy` (`elem` [Mild, Solid, Unbearable]) + + it "stands in as System One" $ do + rt <- pure runtime >>= withSystemOne fast + kept <- interpret rt (keep 0.5 (yesNo "Is this text a joke?")) ["Why was the scarecrow promoted? He was outstanding in his field.", "The meeting is at 3pm in room 4." :: Text] + length kept `shouldBe` 1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,103 @@ +module Main (main) where + +import Agentic +import Agentic.Runtime (Conversation (..)) +import Agentic.Aeson (toAeson) +import Agentic.OpenAI +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Maybe (fromJust) +import Data.Text (Text) +import GHC.Generics (Generic) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Square = Blank | X | O + deriving (Generic, Show, Contract) + +data Row = Row {left :: Square, centre :: Square, right :: Square} + deriving (Generic, Show, Contract) + +data Board = Board {top :: Row, middle :: Row, bottom :: Row} + deriving (Generic, Show, Contract) + +conversation :: Conversation +conversation = + Conversation + { path = [] + , instruction = "Suggest 3 dinosaurs" + , state = Null + , stateSchema = schemaOf SNull + , tools = [ToolSpec "search" "Search the fossil database" (codecSchema (contract @Text))] + , output = codecSchema (contract @[Text]) + , history = [] + } + +at :: J.Key -> J.Value -> J.Value +at k = \case + J.Object o -> fromJust (KeyMap.lookup k o) + other -> error ("not an object: " <> show other) + +body :: Conversation -> J.Value +body = toAeson . requestBody openai + +decoded :: J.Value -> Either String Turn +decoded = either (Left . show) Right . decodeTurn conversation + +main :: IO () +main = hspec $ Test.Hspec.describe "Agentic.OpenAI" $ do + it "asks for strict structured output, wrapped when it isn't an object" $ + at "format" (at "text" (body conversation)) + `shouldBe` fromJust + ( J.decode + "{\"type\":\"json_schema\",\"name\":\"output\",\"strict\":true,\"schema\":{\"type\":\"object\",\ + \\"properties\":{\"value\":{\"type\":\"array\",\"items\":{\"type\":\"string\"}}},\ + \\"required\":[\"value\"],\"additionalProperties\":false}}" + ) + + it "names the schema after its type, and shares repeated types through $defs" $ do + let format = at "format" (at "text" (body conversation {output = codecSchema (contract @Board)})) + schema = at "schema" format + at "name" format `shouldBe` J.String "Board" + at "top" (at "properties" schema) `shouldBe` fromJust (J.decode "{\"$ref\":\"#/$defs/Row\"}") + KeyMap.keys (case at "$defs" schema of J.Object o -> o; _ -> mempty) `shouldMatchList` ["Row", "Square"] + + it "stores nothing, and asks for reasoning it can send back" $ do + at "store" (body conversation) `shouldBe` J.Bool False + at "include" (body conversation) `shouldBe` J.toJSON ["reasoning.encrypted_content" :: Text] + + it "sends tools as strict functions" $ + at "tools" (body conversation) + `shouldBe` fromJust + ( J.decode + "[{\"type\":\"function\",\"name\":\"search\",\"description\":\"Search the fossil database\",\"strict\":true,\ + \\"parameters\":{\"type\":\"object\",\"properties\":{\"value\":{\"type\":\"string\"}},\ + \\"required\":[\"value\"],\"additionalProperties\":false}}]" + ) + + it "sends earlier output items back as input, followed by tool outputs" $ do + let reasoning = Object [("type", String "reasoning"), ("encrypted_content", String "abc")] + call = Object [("type", String "function_call"), ("call_id", String "c1"), ("name", String "search"), ("arguments", String "{\"value\":\"rex\"}")] + c = conversation {history = [Called (Raw (Array [reasoning, call])) [("c1", ToolOk (String "T. rex"))]]} + at "input" (body c) + `shouldBe` fromJust + ( J.decode + "[{\"role\":\"user\",\"content\":\"Suggest 3 dinosaurs\"},\ + \{\"type\":\"reasoning\",\"encrypted_content\":\"abc\"},\ + \{\"type\":\"function_call\",\"call_id\":\"c1\",\"name\":\"search\",\"arguments\":\"{\\\"value\\\":\\\"rex\\\"}\"},\ + \{\"type\":\"function_call_output\",\"call_id\":\"c1\",\"output\":\"T. rex\"}]" + ) + + it "reads function calls, parsing and unwrapping their arguments" $ + fmap action (decoded (fromJust (J.decode "{\"status\":\"completed\",\"output\":[{\"type\":\"reasoning\"},{\"type\":\"function_call\",\"call_id\":\"c1\",\"name\":\"search\",\"arguments\":\"{\\\"value\\\":\\\"rex\\\"}\"}]}"))) + `shouldBe` Right (CallTools [ToolCall "c1" "search" (String "rex")]) + + it "reads a final answer from the message text" $ + fmap action (decoded (fromJust (J.decode "{\"status\":\"completed\",\"output\":[{\"type\":\"message\",\"content\":[{\"type\":\"output_text\",\"text\":\"{\\\"value\\\":[\\\"Stegosaurus\\\"]}\"}]}]}"))) + `shouldBe` Right (Respond (Array [String "Stegosaurus"])) + + it "reports refusals and truncation as errors" $ do + let refusal = decodeTurn conversation (fromJust (J.decode "{\"status\":\"completed\",\"output\":[{\"type\":\"message\",\"content\":[{\"type\":\"refusal\",\"refusal\":\"No.\"}]}]}")) + truncated = decodeTurn conversation (fromJust (J.decode "{\"status\":\"incomplete\",\"incomplete_details\":{\"reason\":\"max_output_tokens\"},\"output\":[]}")) + either (\case Refused "No." -> True; _ -> False) (const False) refusal `shouldBe` True + either (\case Truncated -> True; _ -> False) (const False) truncated `shouldBe` True