diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for agentic-io + +## 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-io.cabal b/agentic-io.cabal new file mode 100644 --- /dev/null +++ b/agentic-io.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: agentic-io +version: 0.2.0.0 +synopsis: IO helpers for agentic runtimes: concurrency, recording and replay +description: + Runs a flow's independent work concurrently, records model calls to a file and replays them, and loads provider keys from a .env file. +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-io + +library + default-language: GHC2021 + default-extensions: LambdaCase OverloadedStrings + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: + Agentic.IO + Agentic.IO.Concurrent + Agentic.IO.DotEnv + Agentic.IO.Store + build-depends: + , agentic ==0.2.* + , agentic-aeson ==0.2.* + , aeson >=2.1 && <2.3 + , async >=2.2 && <2.3 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , text >=2.0 && <2.2 + , base >=4.18 && <5 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 +test-suite agentic-io-test + default-language: GHC2021 + default-extensions: DeriveAnyClass LambdaCase OverloadedStrings + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + , agentic ==0.2.* + , agentic-io ==0.2.* + , base >=4.18 && <5 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 diff --git a/src/Agentic/IO.hs b/src/Agentic/IO.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/IO.hs @@ -0,0 +1,10 @@ +-- | IO helpers for runtimes. +module Agentic.IO + ( module Agentic.IO.Concurrent + , module Agentic.IO.DotEnv + , module Agentic.IO.Store + ) where + +import Agentic.IO.Concurrent +import Agentic.IO.DotEnv +import Agentic.IO.Store diff --git a/src/Agentic/IO/Concurrent.hs b/src/Agentic/IO/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/IO/Concurrent.hs @@ -0,0 +1,12 @@ +-- | Running a flow's independent work at the same time. +module Agentic.IO.Concurrent + ( concurrently + ) where + +import Agentic.Runtime (Runtime (..)) +import Control.Concurrent.Async (mapConcurrently) + +-- | Run 'Agentic.Core.each', 'Control.Arrow.&&&' and parallel tool calls concurrently. If one +-- branch fails, the others are cancelled and the error is raised in the caller. +concurrently :: Runtime IO -> Runtime IO +concurrently rt = rt {parallel = mapConcurrently id} diff --git a/src/Agentic/IO/DotEnv.hs b/src/Agentic/IO/DotEnv.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/IO/DotEnv.hs @@ -0,0 +1,44 @@ +-- | Loading provider keys from a @.env@ file. +module Agentic.IO.DotEnv + ( loadDotEnv + , parseDotEnv + ) where + +import Control.Monad (filterM, forM_, when) +import Data.Char (isSpace) +import Data.List (dropWhileEnd, isPrefixOf) +import Data.Maybe (isNothing, listToMaybe) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (lookupEnv, setEnv) +import System.FilePath (takeDirectory, ()) + +-- | Find the nearest @.env@, from the current directory upwards, and set each +-- variable it defines that isn't already set. Returns the file it loaded. +loadDotEnv :: IO (Maybe FilePath) +loadDotEnv = do + here <- getCurrentDirectory + found <- listToMaybe <$> filterM doesFileExist (map ( ".env") (upwards here)) + forM_ found $ \file -> do + vars <- parseDotEnv <$> readFile file + forM_ vars $ \(key, value) -> do + existing <- lookupEnv key + when (isNothing existing && not (null value)) (setEnv key value) + pure found + where + upwards dir + | takeDirectory dir == dir = [dir] + | otherwise = dir : upwards (takeDirectory dir) + +-- | @KEY=value@ lines. Blank lines and @#@ comments are skipped, an @export@ +-- prefix is allowed, and matching quotes around a value are removed. +parseDotEnv :: String -> [(String, String)] +parseDotEnv = concatMap entry . lines + where + entry raw = case break (== '=') (strip (dropExport (strip raw))) of + (key, '=' : value) | not (null key), not ("#" `isPrefixOf` key) -> [(strip key, unquote (strip value))] + _ -> [] + dropExport l = if "export " `isPrefixOf` l then drop 7 l else l + strip = dropWhileEnd isSpace . dropWhile isSpace + unquote v = case v of + q : rest | q `elem` ("\"'" :: String), not (null rest), last rest == q -> init rest + _ -> v diff --git a/src/Agentic/IO/Store.hs b/src/Agentic/IO/Store.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/IO/Store.hs @@ -0,0 +1,224 @@ +-- | Recording model calls to a file, and replaying them. +-- +-- > rt <- pure runtime >>= withSystemOne jev >>= withSystemTwo anthropic >>= withStore ReplayOrRecord "dino.jsonl" +-- +-- Every System One and System Two call is a request: a t'Conversation' or a +-- t'JudgeRequest'. The store keys each answer by its whole request, so an answer +-- is replayed exactly when the model would be asked exactly the same thing. +-- Change an instruction or a threshold upstream and only the calls it affects +-- go to the model again. +-- +-- Only model calls are stored. @act@ steps and tool bodies run for real, even +-- when replaying. +module Agentic.IO.Store + ( Mode (..) + , withStore + , StoreMiss (..) + ) where + +import Agentic.Aeson (fromAeson) +import Agentic.Core (Instruction (..), Note (..)) +import Agentic.JsonSchema (jsonSchema) +import Agentic.Questions +import Agentic.Runtime +import Agentic.Value (Value (..), lookupField, renderJson) +import Control.Concurrent.MVar +import Control.Exception (Exception (..), throwIO) +import Control.Monad (when) +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Directory (doesFileExist) +import System.IO (IOMode (..), hFlush, withFile) + +data Mode + = Record + -- ^ Call the models and record every answer, starting the file afresh. + | Replay + -- ^ Answer only from the file. A request that isn't there is a t'StoreMiss'. + | ReplayOrRecord + -- ^ Answer from the file when it can, and call the models (and record the + -- answer) when it can't. + deriving (Eq, Show) + +-- | A replayed run asked something the recording doesn't have. +data StoreMiss = StoreMiss FilePath Text + deriving (Show) + +instance Exception StoreMiss where + displayException (StoreMiss file what) = + "The recording " <> file <> " has no answer for " <> T.unpack what + <> ". Something upstream changed; record again, or use ReplayOrRecord." + +-- | Wrap a runtime's System One and System Two with a store in @file@. +withStore :: Mode -> FilePath -> Runtime IO -> IO (Runtime IO) +withStore mode file rt = do + existing <- if mode == Record then pure [] else load file + when (mode == Record) (writeFile file "") + answers <- newIORef (Map.fromList [(canonical k, a) | (k, a) <- existing]) + lock <- newMVar () + let lookupOr key what live = do + known <- Map.lookup (canonical key) <$> readIORef answers + case (known, mode) of + (Just answer, _) | mode /= Record -> pure answer + (_, Replay) -> throwIO (StoreMiss file what) + _ -> do + answer <- live + atomicModifyIORef' answers (\m -> (Map.insert (canonical key) answer m, ())) + withMVar lock $ \_ -> append file key answer + pure answer + one request = + lookupOr (judgeKey request) ("a judgement: " <> questionsText request) (encodeAnswers <$> askSystemOne (systemOne rt) request) + >>= decodedAs (MalformedAnswers ("unreadable stored answers in " <> T.pack file)) decodeAnswers' + two conversation = + lookupOr (turnKey conversation) ("a turn of: " <> instructionText (instruction conversation)) (encodeTurn <$> askSystemTwo (systemTwo rt) conversation) + >>= decodedAs (MalformedAnswers ("an unreadable stored turn in " <> T.pack file)) decodeTurn + pure rt {systemOne = SystemOne one, systemTwo = SystemTwo two} + where + decodedAs :: FlowError -> (Value -> Maybe a) -> Value -> IO a + decodedAs err decode' = maybe (throwIO err) pure . decode' + questionsText r = T.intercalate "; " (map question (requestQuestions r)) + question = \case + AskYesNo q -> q + AskChoice q _ -> q + AskScore q _ -> q + +-- --------------------------------------------------------------------------- +-- The file: one JSON object per line, {"request": …, "answer": …} + +load :: FilePath -> IO [(Value, Value)] +load file = do + exists <- doesFileExist file + if not exists + then pure [] + else do + contents <- LBS.readFile file + pure [entry | line <- LBS.lines contents, not (LBS.null line), Just entry <- [parse line]] + where + parse line = do + v <- fromAeson <$> J.decode line + case v of + Object kvs -> (,) <$> lookupField "request" kvs <*> lookupField "answer" kvs + _ -> Nothing + +append :: FilePath -> Value -> Value -> IO () +append file key answer = withFile file AppendMode $ \h -> do + T.hPutStrLn h (renderJson (Object [("request", key), ("answer", answer)])) + hFlush h + +-- --------------------------------------------------------------------------- +-- Keys + +-- | Keys are compared in a canonical form: object keys sorted, whole numbers as +-- integers. Reading the file back through aeson reorders keys, and order +-- doesn't change which request it is. +canonical :: Value -> Value +canonical = \case + Object kvs -> Object (sortOn fst [(k, canonical v) | (k, v) <- kvs]) + Array vs -> Array (map canonical vs) + Number d | d == fromInteger (round d) -> Integer (round d) + v -> v + +turnKey :: Conversation -> Value +turnKey c = + Object + [ ("kind", String "turn") + , ("path", Array [String (noteName n) | n <- path c]) + , ("instruction", String (instructionText (instruction c))) + , ("state", state c) + , ("stateSchema", jsonSchema (stateSchema c)) + , ("tools", Array [Object [("name", String (specName t)), ("description", String (specDescription t)), ("input", jsonSchema (specInput t))] | t <- tools c]) + , ("output", jsonSchema (output c)) + , ("history", Array (map exchange (history c))) + ] + where + exchange = \case + Called (Raw r) results -> Object [("called", r), ("results", Array [Object [("id", String i), ("result", toolResult res)] | (i, res) <- results])] + Rejected (Raw r) problem -> Object [("rejected", r), ("problem", String problem)] + toolResult = \case + ToolOk v -> Object [("ok", v)] + ToolFailed t -> Object [("failed", String t)] + +judgeKey :: JudgeRequest -> Value +judgeKey r = Object [("kind", String "judgement"), ("state", requestState r), ("questions", Array (map spec (requestQuestions r)))] + where + spec = \case + AskYesNo q -> Object [("yesNo", String q)] + AskChoice q opts -> Object [("choice", String q), ("options", labelled opts)] + AskScore q levels -> Object [("score", String q), ("levels", labelled levels)] + labelled xs = Array [Object [("label", String l), ("description", maybe Null String d)] | (l, d) <- xs] + +-- --------------------------------------------------------------------------- +-- Answers + +encodeTurn :: Turn -> Value +encodeTurn (Turn (Raw r) a) = Object [("raw", r), ("action", act a)] + where + act = \case + CallTools calls -> Object [("callTools", Array [Object [("id", String (callId c)), ("name", String (callName c)), ("input", callInput c)] | c <- calls])] + Respond v -> Object [("respond", v)] + +decodeTurn :: Value -> Maybe Turn +decodeTurn = \case + Object kvs -> do + r <- lookupField "raw" kvs + a <- lookupField "action" kvs + Turn (Raw r) <$> act a + _ -> Nothing + where + act = \case + Object [("respond", v)] -> Just (Respond v) + Object [("callTools", Array calls)] -> CallTools <$> traverse call calls + _ -> Nothing + call = \case + Object kvs -> ToolCall <$> text "id" kvs <*> text "name" kvs <*> lookupField "input" kvs + _ -> Nothing + text k kvs = case lookupField k kvs of + Just (String t) -> Just t + _ -> Nothing + +encodeAnswers :: [Answer] -> Value +encodeAnswers = Array . map answer + where + answer = \case + YesNoAnswer p -> Object [("yesNo", prob p)] + ChoiceAnswer l ps c -> Object [("choice", String l), ("probabilities", Array [Array [String x, prob p] | (x, p) <- ps]), ("confidence", prob c)] + ScoreAnswer pos ps c -> Object [("score", Number pos), ("probabilities", Array [Array [Integer (toInteger i), prob p] | (i, p) <- ps]), ("confidence", prob c)] + prob = Integer . toInteger . basisPoints + +decodeAnswers' :: Value -> Maybe [Answer] +decodeAnswers' = \case + Array xs -> traverse answer xs + _ -> Nothing + where + -- Look fields up by name: the file comes back through aeson, which + -- reorders keys. + answer = \case + Object kvs + | Just p <- lookupField "yesNo" kvs -> YesNoAnswer <$> prob p + | Just (String l) <- lookupField "choice" kvs -> + ChoiceAnswer l <$> (pairs label =<< lookupField "probabilities" kvs) <*> (prob =<< lookupField "confidence" kvs) + | Just pos <- lookupField "score" kvs -> + ScoreAnswer <$> number pos <*> (pairs index =<< lookupField "probabilities" kvs) <*> (prob =<< lookupField "confidence" kvs) + _ -> Nothing + pairs key = \case + Array ps -> traverse (\case Array [k, p] -> (,) <$> key k <*> prob p; _ -> Nothing) ps + _ -> Nothing + label = \case + String t -> Just t + _ -> Nothing + index = \case + Integer i -> Just (fromInteger i) + _ -> Nothing + prob = \case + Integer bp -> Just (fromBasisPoints (fromInteger bp / 10000)) + _ -> Nothing + number = \case + Number d -> Just d + Integer n -> Just (fromInteger n) + _ -> Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,91 @@ +module Main (main) where + +import Agentic +import Agentic.IO +import Agentic.Scripted (alwaysYes, replyingWith, respond) +import Control.Exception (try) +import Data.IORef +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Directory (getTemporaryDirectory, removeFile, doesFileExist) +import System.FilePath (()) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Joke = Joke {setup :: Text, punchline :: Text} + deriving (Generic, Show, Eq, Contract) + +data Groan = Mild | Solid | Unbearable + deriving (Generic, Show, Eq, Options) + +joke :: Joke +joke = Joke "Why was the scarecrow promoted?" "He was outstanding in his field." + +-- | A flow with one draft and one judgement. +flow :: Agentic IO Text (Joke, (YesNo, Choice Groan, Score Groan)) +flow = draft @Joke "a joke about this" >>> (returnA &&& judge ((,,) <$> yesNo "Is it funny?" <*> choice "Reaction?" <*> score "Groaning?")) + +-- | A runtime whose models count their calls. +counting :: IO (Runtime IO, IORef Int, IORef Int) +counting = do + turns <- newIORef 0 + judgements <- newIORef 0 + let SystemTwo two = replyingWith (const (respond joke)) + SystemOne one = alwaysYes 0.8 + pure + ( runtime + { systemTwo = SystemTwo (\c -> modifyIORef turns (+ 1) >> two c) + , systemOne = SystemOne (\r -> modifyIORef judgements (+ 1) >> one r) + } + , turns + , judgements + ) + +-- | A runtime whose models must not be called. +offline :: Runtime IO +offline = + runtime + { systemTwo = SystemTwo (const (fail "the model was called")) + , systemOne = SystemOne (const (fail "Jev was called")) + } + +fresh :: String -> IO FilePath +fresh name = do + dir <- getTemporaryDirectory + let file = dir name + exists <- doesFileExist file + if exists then removeFile file else pure () + pure file + +main :: IO () +main = hspec $ Test.Hspec.describe "withStore" $ do + it "records, then replays without calling the models" $ do + file <- fresh "agentic-store-replay.jsonl" + (live, turns, judgements) <- counting + recording <- withStore Record file live + recorded <- interpret recording flow "scarecrows" + (,) <$> readIORef turns <*> readIORef judgements `shouldReturn` (1, 1) + replaying <- withStore Replay file offline + interpret replaying flow "scarecrows" `shouldReturn` recorded + + it "fails clearly when a replay asks something new" $ do + file <- fresh "agentic-store-miss.jsonl" + (live, _, _) <- counting + recording <- withStore Record file live + _ <- interpret recording flow "scarecrows" + replaying <- withStore Replay file offline + result <- try (interpret replaying flow "penguins") + either (\(StoreMiss _ what) -> what) (const "no miss") result `shouldBe` "a turn of: a joke about this" + + it "replays what it has and records what it doesn't" $ do + file <- fresh "agentic-store-both.jsonl" + (live, turns, _) <- counting + store <- withStore ReplayOrRecord file live + _ <- interpret store flow "scarecrows" + _ <- interpret store flow "scarecrows" + readIORef turns `shouldReturn` 1 + _ <- interpret store flow "penguins" + readIORef turns `shouldReturn` 2 + again <- withStore ReplayOrRecord file offline + _ <- interpret again flow "penguins" + pure ()