diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 AxisVela + +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,191 @@ +# PRAXO-CORE Haskell Core + +PRAXO-CORE is an embeddable, MIT-licensed agent framework. This package is its +native Haskell Core. It implements all eleven declared vector groups and does not +call Go or another Core. It includes a native callback-based agent loop with +tools, policy hooks, typed events, memory, checkpoints, context budgets, +middleware, JSON Schema validation, plugin manifest parsing, and runtime helpers. + +- Implementation type: Core. +- Package version: `0.2.0`; supported `SPEC_VERSION`: `0.2.0`. +- Local gate: all eleven shared vector groups, native regression tests, and + source API/parity checks. +- Linux and Windows CI run the full suite. Hackage publication uses + `.github/workflows/haskell-release.yml`; production readiness is not implied + by the source tag. + +## Registry and Coding-Agent Entry + +- Registry introduction: [REGISTRY.md](https://github.com/axisvela/praxo-core/blob/main/language/haskell/REGISTRY.md) +- Machine-readable entry: [llms.txt](https://github.com/axisvela/praxo-core/blob/main/language/haskell/llms.txt) and [llms.md](https://github.com/axisvela/praxo-core/blob/main/language/haskell/llms.md) +- Coding-agent contract: [docs/getting-started/coding-agents.md](https://github.com/axisvela/praxo-core/blob/main/docs/getting-started/coding-agents.md) +- Registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) + +## Build and Test + +Use GHC 9.0 or newer and Python 3.10 or newer. CI targets GHC 9.12.2 on Linux +and Windows. From the repository root: + +```bash +python language/haskell/run-tests.py +python language/haskell/api-snapshot.py --check +``` + +Set `GHC` or pass `--compiler /path/to/ghc` to select the compiler. Python only +builds and launches the native programs; it does not implement their behavior. +Generated files stay under `language/haskell/build/`. + +For a Cabal source build, from `language/haskell/`: + +```bash +cabal build --offline all +cabal test --offline +cabal run --offline praxo-haskell-conformance -- ../../spec +``` + +The library depends only on GHC's `base` and `containers` packages. No provider, +JSON, or regular-expression package is downloaded by the native test driver. +Offline Cabal builds require those boot packages to be available with GHC. + +## Usage + +```haskell +import Praxo.Json +import Praxo.JsonSchema +import Praxo.ToolCall + +main :: IO () +main = do + print (parseToolCall "{\"name\":\"echo\",\"input\":{\"text\":\"hello\"}}") + print (validateSchema (JObject [("type", JString "string")]) (JNumber 42)) + print (encodeJson (JObject [("runId", JString "run-1")])) +``` + +Public declarations are inventoried in [`api/0.1.0.txt`](api/0.1.0.txt). +This is a source declaration check, not a binary ABI promise. Intentional API +changes require review and regeneration with `python api-snapshot.py`. + +## OpenAI-Compatible Adapter + +`Praxo.OpenAICompatible` builds a `POST {baseUrl}/chat/completions` request with +messages, tools, tool choice, assistant tool calls, and token usage, and maps +provider HTTP failures to `PROVIDER_HTTP`. Streaming is not implemented. + +```haskell +import qualified Praxo.Agent as A +import Praxo.Json +import Praxo.OpenAICompatible + +adapter :: Transport -> OpenAIConfig +adapter transport = OpenAIConfig + { openAIBaseURL = "https://api.example.com/v1" + , openAIModel = "provider-model-id" + , openAIKey = Just "secret" + , openAIToolChoice = Just "auto" + , openAITools = [] + , openAITransport = transport + } + +main :: IO () +main = do + result <- generate (adapter myTransport) [A.Message "user" "hello" [] ""] + print result +``` + +The adapter does not bundle an HTTP client, so the library keeps its `base` and +`containers` dependency set. Supply a synchronous `Transport` that performs the +HTTP exchange for production or tests; deterministic tests use a fake transport. +The Core `Response` type has no finish-reason field, so `finish_reason` is +ignored. + +## Anthropic and Gemini Adapters + +Praxo.Anthropic and Praxo.Gemini build native Messages and +generateContent requests with the same injected Transport seam. + +`haskell +import qualified Praxo.Anthropic as An +import qualified Praxo.Gemini as G +` + +They map tool calls, tool schemas, usage, and provider errors. No HTTP client is +bundled. + +## Harmovela Event Sink + +`Praxo.Harmovela` posts Core events to `POST {baseURL}/events` with the +documented envelope (`spec_version`, `id`, `type`, `source`, `created_at`, +`payload`). Supply a transport and a UTC nanosecond clock; the package keeps its +`base` and `containers` dependency set and does not bundle an HTTP client. + +```haskell +import qualified Praxo.Harmovela as H + +sink :: H.HarmovelaTransport -> IO Integer -> H.HarmovelaSink +sink transport clock = H.newHarmovelaSink + "http://127.0.0.1:8790/aep/api" + transport + clock +``` + +`emitHarmovelaEvent` accepts any 2xx response and returns `HARMOVELA_HTTP` with +the status and a bounded body otherwise. The sink adds no authentication, +retries, buffering, ordering, or exactly-once delivery. Event data may contain +sensitive content, so filter caller-side; use HTTPS for remote endpoints. + +## Declared Scope and Limits + +- JSON parsing is strict, rejects malformed escapes and lone surrogates, and + bounds input to 1,048,576 Haskell characters and nesting to 64. Numbers use + exact rationals with bounded decimal spelling/exponents. Encoding rejects + non-terminating decimal rationals and invalid Unicode scalars. +- JSON object equality is order-independent and uses the last duplicate key. + Plugin manifests additionally reject duplicate fields to avoid ambiguity. +- Tool calls support canonical JSON, closed XML-style blocks, closed dotted + tags, and dotted plain lines. Governance metadata is preserved as strings. + No call ID is generated. DSML, invoke, todo, and skill-install formats are not + implemented. Tool-call input is limited to 262,144 characters; oversized input + is not parsed, and the stripping helper returns it unchanged. This helper is + not a security sanitizer. Do not infer full Go parser parity from the vectors. +- JSON Schema supports object properties/required fields, array items and + lengths, scalar types, enum, numeric bounds, and Unicode code-point lengths. + The reference's zero-bound behavior is preserved. Unknown keywords are ignored. +- Patterns support ASCII literals, dot, ranges/classes, anchors, `*`, `+`, `?`, + and basic escaped classes. This is not full RE2. Unsupported syntax fails + explicitly; work is bounded by pattern and input size. Pattern failures such + as `SCHEMA_PATTERN_UNSUPPORTED` are Core-local, not new wire error codes. + Other `Left` diagnostic strings are also Core-local rather than wire envelopes. +- Plugin checks cover declared manifest fields, entrypoint/isolation, limits, + permissions, health, capabilities, and signature/SBOM declarations. They do + not execute plugins, verify signatures, establish trust, or enforce OS confinement. +- The loop accepts model, tool, and event callbacks returning explicit errors. + It runs tools sequentially, preserves message history, and enforces step and + cumulative input/output token budgets. Negative model-reported input or output + counts fail with the Core-local `AGENT_INVALID_USAGE` error and a `run.failed` + event before that response's tools run, even when the token budget is disabled. + The loop relies on callbacks to report accurate non-negative usage; it cannot + independently verify counts. Callbacks must return errors rather + than throw exceptions; exceptions are not converted to agent errors. Tool + lookup and validation are the caller's responsibility. Events contain only + their kind, not full wire event envelopes. There is no asynchronous streaming + runtime, cancellation, or concurrent session management. +- `Praxo.Runtime` provides memory, event sinks, checkpoints, lexical path policy, + context compaction, and stream-kind constants. `Praxo.Middleware` provides PII + redaction, structured-output validation, call limits, tool selection, and + fallback helpers. The callback-based agent loop does not automatically apply + these opt-in helpers. +- The OpenAI-compatible adapter requires a caller-supplied transport and does + not implement streaming. There is no asynchronous event stream or plugin host + in this Core. Generic JSON can preserve wire field names; typed codecs for + other contract envelopes are not claimed. + +See the [normative specification](../../spec/README.md), +[parity inventory](../../spec/parity/haskell.md), and +[language policy](../../docs/contributing/language-policy.md). +The parity inventory records the implemented Core surfaces. +See [SETUP.md](SETUP.md) for local setup and test commands. + +## License + +MIT. See [LICENSE](LICENSE). `base` and `containers` use BSD-style licenses; +GHC and its runtime are separate toolchain components, not vendored code. diff --git a/REGISTRY.md b/REGISTRY.md new file mode 100644 --- /dev/null +++ b/REGISTRY.md @@ -0,0 +1,42 @@ +# PRAXO-CORE Haskell Registry Introduction + +**Status:** source release; Hackage upload pending. Source version `0.3.0`, source +tag `haskell/v0.3.0`. Published registry version: `0.2.0`. Registry +pages are release snapshots; verify the published version before relying on a +feature. + +## Positioning + +PRAXO-CORE is an embeddable, MIT-licensed agent framework. This package is its native Haskell Core. It implements all eleven declared vector groups and does not call Go or another Core. It includes a native callback-based agent loop with tools, policy hooks, typed events, memory, checkpoints, context budgets, middleware, JSON Schema validation, plugin manifest parsing, and runtime helpers. + +## Package + +| Field | Value | +| --- | --- | +| Package | `praxo-core` | +| Registry | [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) | +| Source version | `0.3.0` | +| Published registry version | `0.2.0` | +| Install (published) | `cabal install praxo-core` | +| Install (source/release prepared) | `cabal install praxo-core` | +| Source tag | `haskell/v0.3.0` | +| Tier | Core | +| Contract | `SPEC_VERSION` `0.2.0` | +| Documentation | https://axisvela.github.io/praxo-core/languages/haskell/ | + +## Coding-agent entry + +- [llms.txt](llms.txt): compact machine-readable entry for this language. +- [llms.md](llms.md): Markdown version of the same entry. +- [Coding-agent contract](../../docs/getting-started/coding-agents.md): explicit + scope, final-argument authorization, denial tests, and verification commands. + +## Boundaries + +- PRAXO-CORE is an embeddable, MIT-licensed execution kernel, not a hosted + model, workflow engine, identity provider, or safety controller. +- Do not infer exactly-once execution, complete sandbox isolation, production + security certification, live-provider behavior, or physical safety from this + package. +- Check the registry page and source tag for the exact version; source READMEs + and canonical documentation may be newer than a published registry page. diff --git a/SETUP.md b/SETUP.md new file mode 100644 --- /dev/null +++ b/SETUP.md @@ -0,0 +1,58 @@ +# Haskell Setup And Tests + +Install GHC 9.0 or newer and Python 3.10 or newer. The Core uses the GHC boot +packages `base` and `containers`; Cabal is optional. The reported Windows run +used GHC 9.12.2. From the repository root, adjust the compiler path for the +local installation: + +```powershell +$env:GHC = 'D:\dev\ghc-9.12.2-x86_64-unknown-mingw32\bin\ghc.exe' +& $env:GHC --version +python language/haskell/run-tests.py +python language/haskell/api-snapshot.py --check +``` + +The test driver builds and runs the native regression tests and all eleven +conformance vector groups, and checks the API snapshot and parity inventory. The +reported Windows run passed all declared vectors and the native runtime, +middleware, and agent tests; the driver's successful run includes the snapshot +check. Alternatively pass `--compiler` to select GHC. Build products go to +`language/haskell/build/`. + +To exercise the conformance executable's argument validation after the driver +builds it, run from the repository root. Both invocations should print usage +and exit nonzero: + +```powershell +& language/haskell/build/conformance/run.exe +$LASTEXITCODE +& language/haskell/build/conformance/run.exe spec extra +$LASTEXITCODE +``` + +Broader repository metadata and parity checks can be run separately: + +```powershell +python scripts/test_layout.py +$env:GOWORK = 'off' +go test ./internal/spec/... +``` + +On Windows, the standalone snapshot check passed, the layout check passed all +8 tests, and the Go specification tests passed. The broader checks are not +part of the Haskell test driver. + +With Cabal and boot packages available, from `language/haskell/`: + +```text +cabal build --offline all +cabal test --offline +cabal run --offline praxo-haskell-conformance -- ../../spec +``` + +The Cabal commands were not verified in the reported Windows run. Offline +execution requires Cabal and the necessary dependencies to be available locally. + +Regenerate the source API inventory after reviewing intentional API changes with +`python language/haskell/api-snapshot.py`. The shared parity inventory currently +does not describe the new agent loop. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple (defaultMain) + +main :: IO () +main = defaultMain diff --git a/api-snapshot.py b/api-snapshot.py new file mode 100644 --- /dev/null +++ b/api-snapshot.py @@ -0,0 +1,87 @@ +import argparse +from pathlib import Path +import re +import sys + + +ROOT = Path(__file__).resolve().parent + + +def snapshot(): + wire = (ROOT / "src/Praxo/Wire.hs").read_text(encoding="utf-8") + sdk = re.search(r'^sdkVersion = "([^"]+)"$', wire, re.MULTILINE)[1] + spec = re.search(r'^specVersion = "([^"]+)"$', wire, re.MULTILINE)[1] + entries = ["# PRAXO-CORE Haskell Wire API " + sdk, "# SPEC_VERSION " + spec, ""] + for path in sorted((ROOT / "src/Praxo").glob("*.hs")): + text = path.read_text(encoding="utf-8") + header = re.search(r"^module (\S+)\s+\((.*?)\)\s+where$", text, re.MULTILINE | re.DOTALL) + if not header: + raise ValueError("missing explicit exports: " + str(path)) + module = header[1] + exports = header[2].replace("(..)", "").split(",") + entries.append("## " + module) + for name in sorted(export.strip() for export in exports): + pattern = r"^(?:(?:data|newtype) " + re.escape(name) + r"\b.*|" + re.escape(name) + r" :: .*)$" + declaration = re.search(pattern, text, re.MULTILINE) + if not declaration: + raise ValueError("missing declaration: " + module + "." + name) + entries.append(declaration[0]) + entries.append("") + return "\n".join(entries) + + +def parity_errors(): + repository = ROOT.parents[1] + wire = (ROOT / "src/Praxo/Wire.hs").read_text(encoding="utf-8") + spec = (repository / "spec/SPEC_VERSION").read_text(encoding="utf-8").strip() + errors = [] + if f'specVersion = "{spec}"' not in wire: + errors.append("Haskell contract version does not match spec/SPEC_VERSION") + version = re.search(r'^version:\s*(\S+)', (ROOT / "praxo-core.cabal").read_text(encoding="utf-8"), re.MULTILINE)[1] + if f'sdkVersion = "{version}"' not in wire: + errors.append("Haskell SDK version does not match Cabal metadata") + text = (repository / "spec/parity/haskell.md").read_text(encoding="utf-8") + rows = 0 + for line in text.splitlines(): + if not line.startswith("| `"): + continue + cells = line.split("|") + symbol = cells[2].strip(" `") + module, name = symbol.rsplit(".", 1) + path = ROOT / "src" / (module.replace(".", "/") + ".hs") + if not path.is_file(): + errors.append("missing parity module: " + module) + continue + header = re.search(r"^module \S+\s+\((.*?)\)\s+where$", path.read_text(encoding="utf-8"), re.MULTILINE | re.DOTALL) + exports = [entry.strip() for entry in header[1].replace("(..)", "").split(",")] + if name not in exports: + errors.append("missing parity export: " + symbol) + rows += 1 + if rows == 0: + errors.append("Haskell parity inventory has no symbols") + return errors + + +def main(): + parser = argparse.ArgumentParser() + parser.add_argument("--check", action="store_true") + args = parser.parse_args() + target = ROOT / "api/0.1.0.txt" + content = snapshot() + if args.check: + if not target.is_file() or target.read_text(encoding="utf-8") != content: + print("API snapshot is missing or stale", file=sys.stderr) + return 1 + errors = parity_errors() + if errors: + print("\n".join(errors), file=sys.stderr) + return 1 + print("Haskell API snapshot is current") + else: + target.parent.mkdir(exist_ok=True) + target.write_text(content, encoding="utf-8", newline="\n") + return 0 + + +if __name__ == "__main__": + raise SystemExit(main()) diff --git a/api/0.1.0.txt b/api/0.1.0.txt new file mode 100644 --- /dev/null +++ b/api/0.1.0.txt @@ -0,0 +1,125 @@ +# PRAXO-CORE Haskell Wire API 0.3.0 +# SPEC_VERSION 0.2.0 + +## Praxo.Agent +data AgentError = AgentError { errorCode :: String, errorMessage :: String } deriving (Eq, Show) +data AgentOptions = AgentOptions { generate :: [Message] -> IO (Either AgentError Response), invoke :: ToolCall -> IO (Either AgentError Json), emit :: String -> IO (Either AgentError ()), maxSteps :: Int, maxTokens :: Integer } +data Message = Message { messageRole :: String, messageContent :: String, messageToolCalls :: [ToolCall], messageToolCallId :: String } deriving (Eq, Show) +data Response = Response { responseContent :: String, responseToolCalls :: [ToolCall], inputTokens :: Integer, outputTokens :: Integer } deriving (Eq, Show) +data RunResult = RunResult { runOutput :: String, runSteps :: Int, runInputTokens :: Integer, runOutputTokens :: Integer, runMessages :: [Message] } deriving (Eq, Show) +data ToolCall = ToolCall { toolCallId :: String, toolCallName :: String, toolCallArguments :: Json } deriving (Eq, Show) +runAgent :: AgentOptions -> [Message] -> String -> IO (Either AgentError RunResult) + +## Praxo.Anthropic +data AnthropicConfig = AnthropicConfig +data AnthropicTool = AnthropicTool +buildAnthropicRequest :: AnthropicConfig -> [Message] -> Either AgentError HttpRequest +generateAnthropic :: AnthropicConfig -> [Message] -> IO (Either AgentError Response) +parseAnthropicResponse :: String -> Either AgentError Response + +## Praxo.Gemini +data GeminiConfig = GeminiConfig +data GeminiTool = GeminiTool +buildGeminiRequest :: GeminiConfig -> [Message] -> Either AgentError HttpRequest +generateGemini :: GeminiConfig -> [Message] -> IO (Either AgentError Response) +parseGeminiResponse :: String -> Either AgentError Response + +## Praxo.Harmovela +data HarmovelaRequest = HarmovelaRequest +data HarmovelaResponse = HarmovelaResponse +data HarmovelaSink = HarmovelaSink +newtype HarmovelaTransport = HarmovelaTransport +buildHarmovelaRequest :: HarmovelaSink -> Event -> IO (Either AgentError HarmovelaRequest) +emitHarmovelaEvent :: HarmovelaSink -> Event -> IO (Either AgentError ()) +formatHarmovelaTimestamp :: Integer -> String +newHarmovelaSink :: String -> HarmovelaTransport -> IO Integer -> HarmovelaSink + +## Praxo.Json +data Json = JObject [(String, Json)] | JArray [Json] | JString String | JNumber Rational | JBool Bool | JNull deriving (Eq, Show) +asArray :: Json -> [Json] +asObject :: Json -> [(String, Json)] +asString :: Json -> String +encodeJson :: Json -> Either String String +equalJson :: Json -> Json -> Bool +field :: String -> Json -> Json +parseJson :: String -> Either String Json + +## Praxo.JsonSchema +data ValidationError = ValidationError { errorPath :: String, errorMessage :: String } deriving (Eq, Show) +validateSchema :: Json -> Json -> Either String [ValidationError] + +## Praxo.Middleware +data CallLimit = CallLimit +data StructuredOutput = StructuredOutput +applyStructured :: StructuredOutput -> String -> Either String String +callLimit :: Int -> Int -> CallLimit +callLimitModel :: CallLimit -> Either String CallLimit +callLimitTool :: CallLimit -> Either String CallLimit +checkToolSelected :: ToolSelection -> String -> Either String () +extractJson :: String -> Maybe Json +fallbackEither :: Either e a -> Either e a -> Either e a +fallbackGenerate :: IO (Either e a) -> IO (Either e a) -> IO (Either e a) +piiRedact :: String -> String +redactValue :: Json -> Json +selectTools :: ToolSelection -> [String] -> [String] +structuredOutput :: Json -> Int -> Maybe (String -> Either String String) -> StructuredOutput +toolSelection :: [String] -> ToolSelection + +## Praxo.OpenAICompatible +data HttpRequest = HttpRequest +data HttpResponse = HttpResponse +data OpenAIConfig = OpenAIConfig +data OpenAITool = OpenAITool +newtype Transport = Transport +buildRequest :: OpenAIConfig -> [Message] -> Either AgentError HttpRequest +generate :: OpenAIConfig -> [Message] -> IO (Either AgentError Response) +parseResponse :: String -> Either AgentError Response + +## Praxo.Pattern +matchPattern :: String -> String -> Either String Bool + +## Praxo.Plugin +parseManifest :: String -> Either String Json +validateManifest :: Json -> Either String () + +## Praxo.Runtime +data ContextBudget = ContextBudget { budgetMaxTokens :: Int, budgetKeepRecent :: Int } deriving (Eq, Show) +data ContextMessage = ContextMessage +data Decision = Decision { decisionAllowed :: Bool, decisionReason :: String } deriving (Eq, Show) +data Event = Event +data MemoryRecord = MemoryRecord +data MemoryStore = MemoryStore +newtype PathChecker = PathChecker [PathGrant] deriving (Eq, Show) +data PathGrant = PathGrant { grantRoot :: String, grantAccess :: String } deriving (Eq, Show) +data Sink = RecordSink [String] | MultiSink [Sink] | FilterSink Sink [String] deriving (Eq, Show) +checkpointMarshal :: CheckpointAllowlist -> String -> Json -> Either String String +checkpointUnmarshal :: CheckpointAllowlist -> String -> Either String Json +compactContext :: ContextBudget -> [ContextMessage] -> ([ContextMessage], Bool) +emitSink :: Sink -> Event -> Sink +estimateTokens :: [ContextMessage] -> Int +filterSink :: Sink -> [String] -> Sink +memoryPut :: MemoryStore -> String -> MemoryRecord -> (MemoryStore, MemoryRecord) +memorySearch :: MemoryStore -> String -> String -> Int -> [MemoryRecord] +messageWire :: ContextMessage -> Json +multiSink :: [Sink] -> Sink +newCheckpoint :: CheckpointAllowlist +newMemoryStore :: MemoryStore +newSink :: Sink +normalizePath :: String -> String +pathAllowed :: PathChecker -> String -> String -> Bool +pathCheck :: PathChecker -> String -> String -> Either String Decision +pathChecker :: [PathGrant] -> Either String PathChecker +registerCheckpoint :: CheckpointAllowlist -> String -> Either String CheckpointAllowlist +sinkKindLists :: Sink -> [[String]] +sinkKinds :: Sink -> [String] +streamKinds :: [String] + +## Praxo.ToolCall +data ToolCall = ToolCall { callName :: String, callInput :: Json, callMetadata :: [(String, String)] } deriving (Eq, Show) +parseInputJson :: String -> Maybe Json +parseToolCall :: String -> Maybe ToolCall +stripToolCallMarkup :: String -> String + +## Praxo.Wire +sdkVersion :: String +specVersion :: String diff --git a/api/0.2.0.txt b/api/0.2.0.txt new file mode 100644 --- /dev/null +++ b/api/0.2.0.txt @@ -0,0 +1,41 @@ +# PRAXO-CORE Haskell Wire API 0.1.0 +# SPEC_VERSION 0.2.0 + +## Praxo.Agent +data AgentError = AgentError { errorCode :: String, errorMessage :: String } deriving (Eq, Show) +data AgentOptions = AgentOptions { generate :: [Message] -> IO (Either AgentError Response), invoke :: ToolCall -> IO (Either AgentError Json), emit :: String -> IO (Either AgentError ()), maxSteps :: Int, maxTokens :: Integer } +data Message = Message { messageRole :: String, messageContent :: String, messageToolCalls :: [ToolCall], messageToolCallId :: String } deriving (Eq, Show) +data Response = Response { responseContent :: String, responseToolCalls :: [ToolCall], inputTokens :: Integer, outputTokens :: Integer } deriving (Eq, Show) +data RunResult = RunResult { runOutput :: String, runSteps :: Int, runInputTokens :: Integer, runOutputTokens :: Integer, runMessages :: [Message] } deriving (Eq, Show) +data ToolCall = ToolCall { toolCallId :: String, toolCallName :: String, toolCallArguments :: Json } deriving (Eq, Show) +runAgent :: AgentOptions -> [Message] -> String -> IO (Either AgentError RunResult) + +## Praxo.Json +data Json = JObject [(String, Json)] | JArray [Json] | JString String | JNumber Rational | JBool Bool | JNull deriving (Eq, Show) +asArray :: Json -> [Json] +asObject :: Json -> [(String, Json)] +asString :: Json -> String +encodeJson :: Json -> Either String String +equalJson :: Json -> Json -> Bool +field :: String -> Json -> Json +parseJson :: String -> Either String Json + +## Praxo.JsonSchema +data ValidationError = ValidationError { errorPath :: String, errorMessage :: String } deriving (Eq, Show) +validateSchema :: Json -> Json -> Either String [ValidationError] + +## Praxo.Pattern +matchPattern :: String -> String -> Either String Bool + +## Praxo.Plugin +parseManifest :: String -> Either String Json +validateManifest :: Json -> Either String () + +## Praxo.ToolCall +data ToolCall = ToolCall { callName :: String, callInput :: Json, callMetadata :: [(String, String)] } deriving (Eq, Show) +parseToolCall :: String -> Maybe ToolCall +stripToolCallMarkup :: String -> String + +## Praxo.Wire +sdkVersion :: String +specVersion :: String diff --git a/conformance/Main.hs b/conformance/Main.hs new file mode 100644 --- /dev/null +++ b/conformance/Main.hs @@ -0,0 +1,228 @@ +module Main (main) where + +import Control.Monad (forM, unless) +import Data.IORef +import Data.List (sort) +import qualified Praxo.Agent as A +import Praxo.Json +import Praxo.JsonSchema +import Praxo.Middleware +import Praxo.Plugin +import Praxo.Runtime +import Praxo.ToolCall +import Praxo.Wire +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (IOMode(ReadMode), hGetContents, hSetEncoding, utf8, withFile) + +main :: IO () +main = do + arguments <- getArgs + spec <- case arguments of + [path] -> pure path + _ -> fail "usage: praxo-haskell-conformance " + failures <- fmap concat $ forM (words "toolcall jsonschema plugin memory event stream checkpoint policy context middleware agent-loop") $ \group -> do + withFile (spec ++ "/vectors/" ++ group ++ ".json") ReadMode $ \handle -> do + hSetEncoding handle utf8 + text <- hGetContents handle + fixture <- either fail pure (parseJson text) + unless (field "specVersion" fixture == JString specVersion && field "group" fixture == JString group) + (fail "unsupported fixture contract or group") + let vectors = asArray (field "vectors" fixture) + unless (not (null vectors)) (fail "empty vector group") + forM vectors $ \vector -> do + let name = asString (field "id" vector) + result <- if group == "agent-loop" then checkAgent (field "input" vector) (field "expect" vector) + else pure (checkVector group (field "input" vector) (field "expect" vector)) + case result of + Right () -> putStrLn ("PASS " ++ name) >> pure [] + Left message -> pure [name ++ ": " ++ message] + let errors = concat failures + unless (null errors) (mapM_ putStrLn errors >> exitFailure) + putStrLn "All declared vector groups passed" + +checkAgent :: Json -> Json -> IO (Either String ()) +checkAgent input expected = do + script <- newIORef (asArray (field "script" input)) + events <- newIORef [] + invocations <- newIORef (0 :: Int) + let number value = case value of JNumber n -> truncate n; _ -> 0 + model _ = do + remaining <- readIORef script + case remaining of + [] -> pure (Left (A.AgentError "SCRIPT" "script exhausted")) + (step:rest) -> do + writeIORef script rest + let call item = A.ToolCall (asString (field "id" item)) (asString (field "name" item)) (field "arguments" item) + pure (Right (A.Response (asString (field "content" step)) (map call (asArray (field "toolCalls" step))) (number (field "inputTokens" step)) (number (field "outputTokens" step)))) + tool call = do + modifyIORef' invocations (+1) + if A.toolCallName call `elem` map (asString . field "name") (asArray (field "tools" input)) + then pure (Right (A.toolCallArguments call)) + else pure (Left (A.AgentError "TOOL_NOT_FOUND" "tool not found")) + sink event = modifyIORef' events (++ [JString event]) >> pure (Right ()) + options = A.AgentOptions model tool sink (fromInteger (number (field "maxSteps" input))) (number (field "maxTokens" input)) + result <- A.runAgent options [] (asString (field "prompt" input)) + actualEvents <- readIORef events + count <- readIORef invocations + pure $ do + case result of + Left err -> do + check (field "error" expected == JBool True) (show err) + check (JString (A.errorCode err) == field "errorCode" expected) "error code mismatch" + Right value -> do + check (field "error" expected /= JBool True) "unexpected success" + check (JString (A.runOutput value) == field "output" expected) "output mismatch" + check (JNumber (fromIntegral (A.runSteps value)) == field "steps" expected) "steps mismatch" + check (JArray actualEvents == field "events" expected) "events mismatch" + check (JNumber (fromIntegral count) == field "toolInvocations" expected) "tool count mismatch" + +checkVector :: String -> Json -> Json -> Either String () +checkVector "toolcall" input expected + | field "operation" input == JString "strip" = + check (stripToolCallMarkup content == asString (field "text" expected)) "stripped text mismatch" + | field "operation" input == JString "parse" = case parseToolCall content of + Nothing -> check (field "nil" expected == JBool True) "expected a tool call" + Just call -> do + check (field "nil" expected /= JBool True) "unexpected tool call" + check (callName call == asString (field "name" expected)) "name mismatch" + check (equalJson (callInput call) (field "input" expected)) "input mismatch" + | otherwise = Left "unknown toolcall operation" + where content = asString (field "content" input) +checkVector "jsonschema" input expected = do + errors <- validateSchema (field "schema" input) (field "data" input) + check (null errors == (field "valid" expected == JBool True)) "validation result mismatch" + check (sort (map errorPath errors) == sort (map asString (asArray (field "errorPaths" expected)))) "validation paths mismatch" +checkVector "plugin" input expected = do + raw <- case field "raw" input of + JString text -> Right text + _ -> encodeJson (field "manifest" input) + case parseManifest raw of + Left _ -> check (field "valid" expected == JBool False) "manifest unexpectedly rejected" + Right manifest -> do + check (field "valid" expected == JBool True) "manifest unexpectedly accepted" + mapM_ (\key -> unless (field key expected == JNull) (check (field key manifest == field key expected) (key ++ " mismatch"))) ["id", "kind"] +checkVector "memory" input expected = + let record item = MemoryRecord + (stringField "id" item) + (stringField "frame" item) + (stringField "content" item) + (stringField "createdAt" item) + store = foldl (\current put -> fst (memoryPut current (stringField "session" put) (record (field "record" put)))) newMemoryStore (asArray (field "puts" input)) + records = memorySearch store (stringField "session" input) (stringField "query" input) (numberField "limit" input) + ids = if null records then JNull else JArray (map (JString . recordId) records) + contents = if null records then JNull else JArray (map (JString . recordContent) records) + in do + check (equalJson ids (field "ids" expected)) "ids mismatch" + check (equalJson contents (field "contents" expected)) "contents mismatch" +checkVector "event" input expected = + let events = [Event (asString kind) "s1" Nothing JNull | kind <- asArray (field "events" input)] + in if stringField "sink" input == "multi" then + let count = max 1 (numberField "sinkCount" input) + final = foldl emitSink (multiSink (replicate count newSink)) events + perSink = JArray [JArray (map JString kinds) | kinds <- sinkKindLists final] + in check (equalJson perSink (field "perSink" expected)) "perSink mismatch" + else + let predicate = map asString (asArray (field "predicateTypes" input)) + final = foldl emitSink (filterSink newSink predicate) events + kinds = sinkKinds final + delivered = if null kinds then JNull else JArray (map JString kinds) + in check (equalJson delivered (field "delivered" expected)) "delivered mismatch" +checkVector "stream" _ expected = + check (JArray (map JString streamKinds) == field "kinds" expected) "stream kinds mismatch" +checkVector "checkpoint" input expected = + let allow = foldl (\current kind -> either (const current) id (registerCheckpoint current (asString kind))) newCheckpoint (asArray (field "registered" input)) + operation = if field "operation" input == JNull then "roundtrip" else stringField "operation" input + kind = stringField "type" input + value = field "value" input + expectedCode = asString (field "errorCode" expected) + codeOf result = case result of Left code -> code; Right _ -> "" + in case operation of + "roundtrip" -> case checkpointMarshal allow kind value of + Left code -> check (code == expectedCode) ("checkpoint error " ++ code) + Right data' -> case checkpointUnmarshal allow data' of + Left code -> check (code == expectedCode) ("checkpoint error " ++ code) + Right decoded -> check (equalJson decoded (field "value" expected)) "checkpoint value mismatch" + "marshal" -> check (codeOf (checkpointMarshal allow kind value) == expectedCode) "marshal error mismatch" + "unmarshal" -> case encodeJson (JObject [("type", JString kind), ("data", value)]) of + Left detail -> Left detail + Right envelope -> check (codeOf (checkpointUnmarshal allow envelope) == expectedCode) "unmarshal error mismatch" + _ -> Left "unknown checkpoint operation" +checkVector "policy" input expected = + let grants = [PathGrant (stringField "root" item) (if field "access" item == JNull then "read" else stringField "access" item) | item <- asArray (field "grants" input)] + target = stringField "target" input + need = if field "need" input == JNull then "read" else stringField "need" input + result = pathChecker grants >>= \checker -> pathCheck checker target need + in if field "error" expected == JBool True + then case result of + Left _ -> Right () + Right _ -> Left "expected policy error" + else case result of + Left code -> Left ("policy error " ++ code) + Right decision -> check (decisionAllowed decision == (field "allowed" expected == JBool True)) "allowed mismatch" +checkVector "context" input expected = + let messages = [ContextMessage (stringField "role" item) (stringField "content" item) [] [] Nothing | item <- asArray (field "messages" input)] + operation = stringField "operation" input + in if operation == "estimate" + then check (estimateTokens messages == numberField "tokens" expected) "token estimate mismatch" + else + let budgetNode = field "budget" input + budget = ContextBudget (numberField "maxTokens" budgetNode) (numberField "keepRecent" budgetNode) + (output, ok) = compactContext budget messages + in do + check (ok == (field "ok" expected == JBool True)) "context ok mismatch" + if ok + then do + check (estimateTokens output == numberField "tokens" expected) "compacted token mismatch" + check (equalJson (JArray (map messageWire output)) (field "messages" expected)) "compacted messages mismatch" + else Right () +checkVector "middleware" input expected = + case stringField "operation" input of + "pii" -> check (piiRedact (stringField "text" input) == stringField "text" expected) "pii mismatch" + "pii-value" -> check (equalJson (redactValue (field "value" input)) (field "value" expected)) "pii value mismatch" + "structured" -> + let repairText = field "repairOutput" input + repair = if repairText == JNull then Nothing else Just (\_ -> Right (asString repairText)) + config = structuredOutput (field "schema" input) (numberField "maxRepairs" input) repair + in case applyStructured config (stringField "output" input) of + Right output -> do + check (field "ok" expected == JBool True) "expected structured error" + check (output == stringField "output" expected) "structured output mismatch" + Left code -> do + check (field "ok" expected /= JBool True) "expected structured success" + check (code == stringField "errorCode" expected) "structured error code mismatch" + "call-limit" -> + let limit = callLimit (numberField "modelLimit" input) (numberField "toolLimit" input) + step (current, outcomes) call = + case asString call of + "model" -> case callLimitModel current of + Left code -> (current, outcomes ++ [code]) + Right next -> (next, outcomes ++ ["ok"]) + _ -> case callLimitTool current of + Left code -> (current, outcomes ++ [code]) + Right next -> (next, outcomes ++ ["ok"]) + (_, outcomes) = foldl step (limit, []) (asArray (field "calls" input)) + in check (JArray (map JString outcomes) == field "outcomes" expected) "call limit mismatch" + "tool-selection" -> + let selection = toolSelection (map asString (asArray (field "selected" input))) + tools = map asString (asArray (field "tools" input)) + advertised = selectTools selection tools + reject = either id (const "ok") (checkToolSelected selection (stringField "requested" input)) + in do + check (JArray (map JString advertised) == field "advertised" expected) "advertised tools mismatch" + check (reject == stringField "reject" expected) "tool selection reject mismatch" + "fallback" -> + let content = stringField "fallbackContent" input + in check (fallbackEither (Left "MODEL_ERROR" :: Either String String) (Right content) == Right content) "fallback mismatch" + _ -> Left "unknown middleware operation" +checkVector _ _ _ = Left "unsupported vector group" + +check :: Bool -> String -> Either String () +check True _ = Right () +check False message = Left message + +stringField :: String -> Json -> String +stringField name = asString . field name + +numberField :: String -> Json -> Int +numberField name value = case field name value of JNumber number -> truncate number; _ -> 0 diff --git a/llms.md b/llms.md new file mode 100644 --- /dev/null +++ b/llms.md @@ -0,0 +1,35 @@ +# PRAXO-CORE Haskell + +> Embeddable, governed agent execution kernel. This file is the language-specific +> registry and coding-agent entry; it does not guarantee discovery, installation, +> or adoption. + +## Package + +- package: `praxo-core` +- registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) +- source_version: `0.3.0` +- published_version: `0.2.0` +- install_published: `cabal install praxo-core` +- install_source: `cabal install praxo-core` +- source_tag: `haskell/v0.3.0` +- tier: Core +- contract: `SPEC_VERSION` `0.2.0` +- documentation: https://axisvela.github.io/praxo-core/languages/haskell/ + +## Start + +- README: `README.md` +- Registry introduction: `REGISTRY.md` +- Markdown entry: `llms.md` +- Compact entry: `llms.txt` +- Coding-agent contract: ../../docs/getting-started/coding-agents.md + +## Boundaries + +- In-process framework; not a model provider, hosted service, workflow engine, + identity provider, or safety controller. +- No exactly-once, sandbox-isolation, production-security, real-time, or + physical-safety claim. +- Registry pages are release snapshots. Verify the published version and read the + canonical documentation for behavior and limits. diff --git a/llms.txt b/llms.txt new file mode 100644 --- /dev/null +++ b/llms.txt @@ -0,0 +1,35 @@ +# PRAXO-CORE Haskell + +> Embeddable, governed agent execution kernel. This file is the language-specific +> registry and coding-agent entry; it does not guarantee discovery, installation, +> or adoption. + +# Package + +- package: `praxo-core` +- registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) +- source_version: `0.3.0` +- published_version: `0.2.0` +- install_published: `cabal install praxo-core` +- install_source: `cabal install praxo-core` +- source_tag: `haskell/v0.3.0` +- tier: Core +- contract: `SPEC_VERSION` `0.2.0` +- documentation: https://axisvela.github.io/praxo-core/languages/haskell/ + +# Start + +- README: `README.md` +- Registry introduction: `REGISTRY.md` +- Markdown entry: `llms.md` +- Compact entry: `llms.txt` +- Coding-agent contract: ../../docs/getting-started/coding-agents.md + +# Boundaries + +- In-process framework; not a model provider, hosted service, workflow engine, + identity provider, or safety controller. +- No exactly-once, sandbox-isolation, production-security, real-time, or + physical-safety claim. +- Registry pages are release snapshots. Verify the published version and read the + canonical documentation for behavior and limits. diff --git a/praxo-core.cabal b/praxo-core.cabal new file mode 100644 --- /dev/null +++ b/praxo-core.cabal @@ -0,0 +1,43 @@ +cabal-version: 2.4 +name: praxo-core +version: 0.3.0 +synopsis: Embeddable MIT-licensed agent framework for Haskell +description: Native agent loop with tools, policy hooks, typed events, memory, + checkpoints, context budgets, middleware, JSON Schema validation, + and plugin manifest parsing for the PRAXO-CORE agent framework. +category: Development +maintainer: AxisVela +homepage: https://axisvela.github.io/praxo-core/ +bug-reports: https://github.com/axisvela/praxo-core/issues +license: MIT +license-file: LICENSE +author: AxisVela +build-type: Simple +extra-source-files: README.md, REGISTRY.md, llms.txt, llms.md, SETUP.md, + api/0.1.0.txt, api/0.2.0.txt, run-tests.py, api-snapshot.py + +source-repository head + type: git + location: https://github.com/axisvela/praxo-core + +library + hs-source-dirs: src + exposed-modules: Praxo.Agent, Praxo.Json, Praxo.ToolCall, Praxo.JsonSchema, Praxo.Pattern, Praxo.Plugin, Praxo.Runtime, Praxo.Middleware, Praxo.Wire, Praxo.OpenAICompatible, Praxo.Anthropic, Praxo.Gemini, Praxo.Harmovela + build-depends: base >=4.14 && <5, containers >=0.6 && <0.9 + default-language: Haskell2010 + ghc-options: -Wall + +executable praxo-haskell-conformance + hs-source-dirs: conformance + main-is: Main.hs + build-depends: base >=4.14 && <5, praxo-core + default-language: Haskell2010 + ghc-options: -Wall + +test-suite wire-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: base >=4.14 && <5, praxo-core + default-language: Haskell2010 + ghc-options: -Wall diff --git a/run-tests.py b/run-tests.py new file mode 100644 --- /dev/null +++ b/run-tests.py @@ -0,0 +1,33 @@ +import argparse +import os +from pathlib import Path +import shutil +import subprocess +import sys + + +ROOT = Path(__file__).resolve().parent + + +def main(): + parser = argparse.ArgumentParser() + parser.add_argument("--compiler", default=os.environ.get("GHC", "ghc")) + args = parser.parse_args() + compiler = shutil.which(args.compiler) + if not compiler: + parser.error("Haskell compiler not found; set GHC or pass --compiler") + subprocess.run([sys.executable, str(ROOT / "api-snapshot.py"), "--check"], check=True) + for suite in ("tests", "conformance"): + output = ROOT / "build" / suite + output.mkdir(parents=True, exist_ok=True) + binary = output / ("run.exe" if os.name == "nt" else "run") + subprocess.run([compiler, "--make", "-Wall", "-isrc", "-outputdir", str(output), + "-o", str(binary), suite + "/Main.hs"], cwd=ROOT, check=True) + command = [str(binary)] + if suite == "conformance": + command.append(str(ROOT.parents[1] / "spec")) + subprocess.run(command, cwd=ROOT, check=True) + + +if __name__ == "__main__": + main() diff --git a/src/Praxo/Agent.hs b/src/Praxo/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Agent.hs @@ -0,0 +1,64 @@ +module Praxo.Agent (AgentError(..), ToolCall(..), Message(..), Response(..), AgentOptions(..), RunResult(..), runAgent) where + +import Praxo.Json (Json, encodeJson) + +data AgentError = AgentError { errorCode :: String, errorMessage :: String } deriving (Eq, Show) +data ToolCall = ToolCall { toolCallId :: String, toolCallName :: String, toolCallArguments :: Json } deriving (Eq, Show) +data Message = Message { messageRole :: String, messageContent :: String, messageToolCalls :: [ToolCall], messageToolCallId :: String } deriving (Eq, Show) +data Response = Response { responseContent :: String, responseToolCalls :: [ToolCall], inputTokens :: Integer, outputTokens :: Integer } deriving (Eq, Show) +data AgentOptions = AgentOptions { generate :: [Message] -> IO (Either AgentError Response), invoke :: ToolCall -> IO (Either AgentError Json), emit :: String -> IO (Either AgentError ()), maxSteps :: Int, maxTokens :: Integer } +data RunResult = RunResult { runOutput :: String, runSteps :: Int, runInputTokens :: Integer, runOutputTokens :: Integer, runMessages :: [Message] } deriving (Eq, Show) + +runAgent :: AgentOptions -> [Message] -> String -> IO (Either AgentError RunResult) +runAgent options history prompt = do + started <- emit options "run.started" + case started of + Left err -> pure (Left err) + Right () -> do + result <- loop 1 0 0 (history ++ [Message "user" prompt [] ""]) + case result of + Left err -> do + _ <- emit options "run.failed" + pure (Left err) + Right value -> do + completed <- emit options "run.completed" + case completed of + Left err -> do + _ <- emit options "run.failed" + pure (Left err) + Right () -> pure (Right value) + where + limit = if maxSteps options > 0 then maxSteps options else 8 + loop step usedIn usedOut messages + | step > limit = pure (Left (AgentError "AGENT_MAX_STEPS" "agent: maximum steps exceeded")) + | otherwise = do + generated <- generate options messages + case generated of + Left err -> pure (Left err) + Right response | inputTokens response < 0 || outputTokens response < 0 -> + pure (Left (AgentError "AGENT_INVALID_USAGE" "agent: token usage must be non-negative")) + Right response -> do + let totalIn = usedIn + inputTokens response + totalOut = usedOut + outputTokens response + next = messages ++ [Message "assistant" (responseContent response) (responseToolCalls response) ""] + if maxTokens options > 0 && totalIn + totalOut > maxTokens options + then pure (Left (AgentError "AGENT_MAX_TOKENS" "agent: maximum tokens exceeded")) + else if null (responseToolCalls response) + then pure (Right (RunResult (responseContent response) step totalIn totalOut next)) + else do + result <- tools next (responseToolCalls response) + case result of + Left err -> pure (Left err) + Right updated -> loop (step + 1) totalIn totalOut updated + tools messages [] = pure (Right messages) + tools messages (call:rest) = do + event <- emit options "tool.call" + case event of + Left err -> pure (Left err) + Right () -> do + result <- invoke options call + case result of + Left err -> pure (Left err) + Right value -> case encodeJson value of + Left detail -> pure (Left (AgentError "TOOL_RESULT" detail)) + Right content -> tools (messages ++ [Message "tool" content [] (toolCallId call)]) rest diff --git a/src/Praxo/Anthropic.hs b/src/Praxo/Anthropic.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Anthropic.hs @@ -0,0 +1,171 @@ +module Praxo.Anthropic + ( AnthropicTool(..) + , AnthropicConfig(..) + , buildAnthropicRequest + , parseAnthropicResponse + , generateAnthropic + ) where + +import Data.List (intercalate) +import Praxo.Agent (AgentError(..), Message(..), Response(..), ToolCall(..)) +import Praxo.Json (Json(..), asArray, asString, encodeJson, field, parseJson) +import Praxo.OpenAICompatible (HttpRequest(..), HttpResponse(..), Transport(..)) + +data AnthropicTool = AnthropicTool + { anthropicToolName :: String + , anthropicToolDescription :: String + , anthropicToolParameters :: Json + } deriving (Eq, Show) + +data AnthropicConfig = AnthropicConfig + { anthropicBaseURL :: String + , anthropicModel :: String + , anthropicKey :: Maybe String + , anthropicVersion :: String + , anthropicMaxTokens :: Integer + , anthropicToolChoice :: Maybe String + , anthropicTools :: [AnthropicTool] + , anthropicTransport :: Transport + } + +buildAnthropicRequest :: AnthropicConfig -> [Message] -> Either AgentError HttpRequest +buildAnthropicRequest config messages + | null (anthropicBaseURL config) = Left (AgentError "PROVIDER_HTTP" "provider base URL is required") + | otherwise = do + (system, encoded) <- messagesJson messages + let toolValues = map toolJson (anthropicTools config) + base = + [ ("model", JString (anthropicModel config)) + , ("max_tokens", JNumber (fromIntegral (anthropicMaxTokens config))) + , ("messages", JArray encoded) + ] + withSystem = if null system then base else base ++ [("system", JString (intercalate "\n\n" system))] + withTools = if null toolValues then withSystem else withSystem ++ [("tools", JArray toolValues)] + withChoice = case anthropicToolChoice config of + Just "auto" -> withTools ++ [("tool_choice", choice "auto")] + Just "required" -> withTools ++ [("tool_choice", choice "any")] + Just "none" -> withTools ++ [("tool_choice", choice "none")] + _ -> withTools + case encodeJson (JObject withChoice) of + Left detail -> Left (AgentError "PROVIDER_REQUEST" detail) + Right text -> + Right HttpRequest + { httpMethod = "POST" + , httpURL = trimSlash (anthropicBaseURL config) ++ "/v1/messages" + , httpHeaders = + [ ("Content-Type", "application/json") + , ("Accept", "application/json") + ] ++ case anthropicKey config of + Nothing -> [] + Just key -> [("x-api-key", key), ("anthropic-version", anthropicVersion config)] + , httpBody = text + } + where + choice value = JObject [("type", JString value)] + trimSlash = reverse . dropWhile (== '/') . reverse + +messagesJson :: [Message] -> Either AgentError ([String], [Json]) +messagesJson messages = go messages [] [] [] + where + go [] system out pending = do + flushed <- flush pending out + pure (reverse system, reverse flushed) + go (message : rest) system out pending + | messageRole message == "system" = + go rest (messageContent message : system) out pending + | messageRole message == "tool" = + go rest system out (pending ++ [toolResult message]) + | otherwise = do + flushed <- flush pending out + content <- messageContentJson message + go rest system (if null content then flushed else JObject + [("role", JString (messageRole message)), ("content", JArray content)] : flushed) [] + flush [] out = pure out + flush pending out = pure (JObject [("role", JString "user"), ("content", JArray pending)] : out) + +toolResult :: Message -> Json +toolResult message = JObject + [ ("type", JString "tool_result") + , ("tool_use_id", JString (messageToolCallId message)) + , ("content", JString (messageContent message)) + ] + +messageContentJson :: Message -> Either AgentError [Json] +messageContentJson message = do + calls <- mapM callJson (messageToolCalls message) + let text = if null (messageContent message) then [] else [JObject [("type", JString "text"), ("text", JString (messageContent message))]] + pure (text ++ calls) + where + callJson call = + pure (JObject + [ ("type", JString "tool_use") + , ("id", JString (toolCallId call)) + , ("name", JString (toolCallName call)) + , ("input", toolCallArguments call) + ]) + +toolJson :: AnthropicTool -> Json +toolJson tool = JObject + [ ("name", JString (anthropicToolName tool)) + , ("description", JString (anthropicToolDescription tool)) + , ("input_schema", parameters) + ] + where + parameters = case anthropicToolParameters tool of + JNull -> JObject [("type", JString "object")] + value -> value + +parseAnthropicResponse :: String -> Either AgentError Response +parseAnthropicResponse text = do + root <- parseJson text `orAgent` "PROVIDER_RESPONSE" + if field "error" root /= JNull + then Left (AgentError "PROVIDER_HTTP" "anthropic: provider error") + else do + allCalls <- mapM callFromJson (asArray (field "content" root)) + let calls = filter (\call -> not (null (toolCallName call))) allCalls + content = concatMap blockText (asArray (field "content" root)) + usage = field "usage" root + pure Response + { responseContent = content + , responseToolCalls = calls + , inputTokens = jsonInteger (field "input_tokens" usage) + , outputTokens = jsonInteger (field "output_tokens" usage) + } + where + blockText block = if asString (field "type" block) == "text" + then asString (field "text" block) else "" + callFromJson block + | asString (field "type" block) /= "tool_use" = Right emptyCall + | otherwise = Right ToolCall + { toolCallId = asString (field "id" block) + , toolCallName = asString (field "name" block) + , toolCallArguments = case field "input" block of + value@(JObject _) -> value + _ -> JObject [] + } + emptyCall = ToolCall "" "" (JObject []) + +generateAnthropic :: AnthropicConfig -> [Message] -> IO (Either AgentError Response) +generateAnthropic config messages = + case buildAnthropicRequest config messages of + Left errorValue -> pure (Left errorValue) + Right httpRequest -> do + result <- sendTransport (anthropicTransport config) httpRequest + pure $ case result of + Left errorValue -> Left errorValue + Right response + | httpStatus response < 200 || httpStatus response >= 300 -> + Left (AgentError "PROVIDER_HTTP" + ("provider returned HTTP " ++ show (httpStatus response) ++ ": " ++ bounded (httpResponseBody response))) + | otherwise -> parseAnthropicResponse (httpResponseBody response) + +orAgent :: Either String Json -> String -> Either AgentError Json +orAgent (Right value) _ = Right value +orAgent (Left detail) code = Left (AgentError code detail) + +jsonInteger :: Json -> Integer +jsonInteger (JNumber value) = truncate value +jsonInteger _ = 0 + +bounded :: String -> String +bounded text = if length text > 512 then take 512 text else text diff --git a/src/Praxo/Gemini.hs b/src/Praxo/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Gemini.hs @@ -0,0 +1,162 @@ +module Praxo.Gemini + ( GeminiTool(..) + , GeminiConfig(..) + , buildGeminiRequest + , parseGeminiResponse + , generateGemini + ) where + +import Praxo.Agent (AgentError(..), Message(..), Response(..), ToolCall(..)) +import Praxo.Json (Json(..), asArray, asString, encodeJson, field, parseJson) +import Praxo.OpenAICompatible (HttpRequest(..), HttpResponse(..), Transport(..)) + +data GeminiTool = GeminiTool + { geminiToolName :: String + , geminiToolDescription :: String + , geminiToolParameters :: Json + } deriving (Eq, Show) + +data GeminiConfig = GeminiConfig + { geminiBaseURL :: String + , geminiModel :: String + , geminiKey :: Maybe String + , geminiMaxOutputTokens :: Integer + , geminiToolChoice :: Maybe String + , geminiTools :: [GeminiTool] + , geminiTransport :: Transport + } + +buildGeminiRequest :: GeminiConfig -> [Message] -> Either AgentError HttpRequest +buildGeminiRequest config messages = do + (system, contents) <- contentsJson messages + let declarations = map toolJson (geminiTools config) + base = [("contents", JArray contents)] + withSystem = if null system then base else base ++ [("system_instruction", JObject [("parts", JArray (map (\text -> JObject [("text", JString text)]) system))])] + withTools = if null declarations then withSystem else withSystem ++ + [ ("tools", JArray [JObject [("functionDeclarations", JArray declarations)]]) + , ("toolConfig", JObject [("functionCallingConfig", JObject [("mode", JString (toolMode (geminiToolChoice config)))])]) + ] + withGeneration = if geminiMaxOutputTokens config > 0 + then withTools ++ [("generationConfig", JObject [("maxOutputTokens", JNumber (fromIntegral (geminiMaxOutputTokens config)))])] + else withTools + case encodeJson (JObject withGeneration) of + Left detail -> Left (AgentError "PROVIDER_REQUEST" detail) + Right text -> + Right HttpRequest + { httpMethod = "POST" + , httpURL = trimSlash (geminiBaseURL config) ++ "/v1beta/models/" ++ geminiModel config ++ ":generateContent" + , httpHeaders = + [ ("Content-Type", "application/json") + , ("Accept", "application/json") + ] ++ case geminiKey config of + Nothing -> [] + Just key -> [("x-goog-api-key", key)] + , httpBody = text + } + where + toolMode (Just "required") = "ANY" + toolMode (Just "none") = "NONE" + toolMode _ = "AUTO" + trimSlash = reverse . dropWhile (== '/') . reverse + +contentsJson :: [Message] -> Either AgentError ([String], [Json]) +contentsJson messages = go messages [] [] [] [] + where + go [] system out pending _ = do + flushed <- flush pending out + pure (reverse system, reverse flushed) + go (message : rest) system out pending names + | messageRole message == "system" = + go rest (messageContent message : system) out pending names + | messageRole message == "tool" = + let name = maybe (messageToolCallId message) id (lookup (messageToolCallId message) names) + result = JObject [("functionResponse", JObject + [ ("name", JString name) + , ("response", JObject [("result", JString (messageContent message))]) + ])] + in go rest system out (pending ++ [result]) names + | otherwise = do + flushed <- flush pending out + parts <- partsJson message + let role = if messageRole message == "assistant" then "model" else "user" + names' = names ++ [(toolCallId call, toolCallName call) | call <- messageToolCalls message, not (null (toolCallId call)), not (null (toolCallName call))] + go rest system (if null parts then flushed else JObject [("role", JString role), ("parts", JArray parts)] : flushed) [] names' + flush [] out = pure out + flush pending out = pure (JObject [("role", JString "user"), ("parts", JArray pending)] : out) + +partsJson :: Message -> Either AgentError [Json] +partsJson message = do + let text = if null (messageContent message) then [] else [JObject [("text", JString (messageContent message))]] + pure (text ++ map callJson (messageToolCalls message)) + where + callJson call = JObject [("functionCall", JObject + [ ("name", JString (toolCallName call)) + , ("args", toolCallArguments call) + ])] + +toolJson :: GeminiTool -> Json +toolJson tool = JObject + [ ("name", JString (geminiToolName tool)) + , ("description", JString (geminiToolDescription tool)) + , ("parameters", parameters) + ] + where + parameters = case geminiToolParameters tool of + JNull -> JObject [("type", JString "object")] + value -> value + +parseGeminiResponse :: String -> Either AgentError Response +parseGeminiResponse text = do + root <- parseJson text `orAgent` "PROVIDER_RESPONSE" + if field "error" root /= JNull + then Left (AgentError "PROVIDER_HTTP" "gemini: provider error") + else case asArray (field "candidates" root) of + [] -> Left (AgentError "PROVIDER_HTTP" "gemini: empty response") + candidate : _ -> do + let content = field "content" candidate + parts = asArray (field "parts" content) + allCalls <- mapM callFromJson (zip [1 ..] parts) + let calls = filter (\call -> not (null (toolCallName call))) allCalls + let textValue = concatMap (\part -> asString (field "text" part)) parts + usage = field "usageMetadata" root + pure Response + { responseContent = textValue + , responseToolCalls = calls + , inputTokens = jsonInteger (field "promptTokenCount" usage) + , outputTokens = jsonInteger (field "candidatesTokenCount" usage) + } + where + callFromJson (index, part) = case field "functionCall" part of + JObject _ -> Right ToolCall + { toolCallId = "call-" ++ show index + , toolCallName = asString (field "name" (field "functionCall" part)) + , toolCallArguments = case field "args" (field "functionCall" part) of + value@(JObject _) -> value + _ -> JObject [] + } + _ -> Right (ToolCall "" "" (JObject [])) + +generateGemini :: GeminiConfig -> [Message] -> IO (Either AgentError Response) +generateGemini config messages = + case buildGeminiRequest config messages of + Left errorValue -> pure (Left errorValue) + Right httpRequest -> do + result <- sendTransport (geminiTransport config) httpRequest + pure $ case result of + Left errorValue -> Left errorValue + Right response + | httpStatus response < 200 || httpStatus response >= 300 -> + Left (AgentError "PROVIDER_HTTP" + ("provider returned HTTP " ++ show (httpStatus response) ++ ": " ++ bounded (httpResponseBody response))) + | otherwise -> parseGeminiResponse (httpResponseBody response) + +orAgent :: Either String Json -> String -> Either AgentError Json +orAgent (Right value) _ = Right value +orAgent (Left detail) code = Left (AgentError code detail) + +jsonInteger :: Json -> Integer +jsonInteger (JNumber value) = truncate value +jsonInteger _ = 0 + +bounded :: String -> String +bounded text = if length text > 512 then take 512 text else text diff --git a/src/Praxo/Harmovela.hs b/src/Praxo/Harmovela.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Harmovela.hs @@ -0,0 +1,159 @@ +module Praxo.Harmovela + ( HarmovelaRequest(..) + , HarmovelaResponse(..) + , HarmovelaTransport(..) + , HarmovelaSink(..) + , newHarmovelaSink + , buildHarmovelaRequest + , emitHarmovelaEvent + , formatHarmovelaTimestamp + ) where + +import Data.Char (isSpace) +import Praxo.Agent (AgentError(..)) +import Praxo.Json (Json(..), encodeJson) +import Praxo.Runtime (Event(..)) + +data HarmovelaRequest = HarmovelaRequest + { harmovelaMethod :: String + , harmovelaURL :: String + , harmovelaHeaders :: [(String, String)] + , harmovelaBody :: String + } deriving (Eq, Show) + +data HarmovelaResponse = HarmovelaResponse + { harmovelaStatus :: Int + , harmovelaResponseBody :: String + } deriving (Eq, Show) + +newtype HarmovelaTransport = HarmovelaTransport + { sendHarmovela :: HarmovelaRequest -> IO (Either AgentError HarmovelaResponse) + } + +data HarmovelaSink = HarmovelaSink + { harmovelaBaseURL :: String + , harmovelaSource :: String + , harmovelaSpecVersion :: String + , harmovelaClock :: IO Integer + , harmovelaTransport :: HarmovelaTransport + } + +newHarmovelaSink :: String -> HarmovelaTransport -> IO Integer -> HarmovelaSink +newHarmovelaSink base transport clock = HarmovelaSink + { harmovelaBaseURL = base + , harmovelaSource = "praxo-core" + , harmovelaSpecVersion = "0.2" + , harmovelaClock = clock + , harmovelaTransport = transport + } + +buildHarmovelaRequest :: HarmovelaSink -> Event -> IO (Either AgentError HarmovelaRequest) +buildHarmovelaRequest sink event + | null (harmovelaBaseURL sink) = + pure (Left (AgentError "HARMOVELA_URL" "harmovela: base URL is required")) + | otherwise = do + nanos <- harmovelaClock sink + case encodeJson (envelope sink event nanos) of + Left detail -> pure (Left (AgentError "HARMOVELA_ENVELOPE" detail)) + Right body -> pure (Right HarmovelaRequest + { harmovelaMethod = "POST" + , harmovelaURL = trimSlash (harmovelaBaseURL sink) ++ "/events" + , harmovelaHeaders = [("content-type", "application/json")] + , harmovelaBody = body + }) + +emitHarmovelaEvent :: HarmovelaSink -> Event -> IO (Either AgentError ()) +emitHarmovelaEvent sink event = do + request <- buildHarmovelaRequest sink event + case request of + Left err -> pure (Left err) + Right httpRequest -> do + response <- sendHarmovela (harmovelaTransport sink) httpRequest + pure $ case response of + Left err -> Left err + Right value + | harmovelaStatus value >= 200 && harmovelaStatus value < 300 -> Right () + | otherwise -> Left (AgentError "HARMOVELA_HTTP" + ("harmovela: HTTP " ++ show (harmovelaStatus value) ++ ": " ++ bounded (harmovelaResponseBody value))) + +envelope :: HarmovelaSink -> Event -> Integer -> Json +envelope sink event nanos = JObject + [ ("spec_version", JString (specVersion sink)) + , ("id", JString (eventID event nanos)) + , ("type", JString (eventKind event)) + , ("source", JString (source sink)) + , ("created_at", JString (formatHarmovelaTimestamp nanos)) + , ("payload", JObject (payload event)) + ] + +payload :: Event -> [(String, Json)] +payload event = + let base = case eventData event of + JObject fields -> fields + _ -> [] + in apply "session_id" (maybeValue (eventSessionId event)) (apply "run_id" (maybeValue =<< eventRunId event) base) + +maybeValue :: String -> Maybe String +maybeValue "" = Nothing +maybeValue value = Just value + +apply :: String -> Maybe String -> [(String, Json)] -> [(String, Json)] +apply _ Nothing fields = fields +apply key (Just value) fields = filter ((/= key) . fst) fields ++ [(key, JString value)] + +eventID :: Event -> Integer -> String +eventID event nanos = + let prefix = case eventRunId event of + Just run | not (null run) -> run + _ -> if null (eventSessionId event) then "event" else eventSessionId event + in prefix ++ "-" ++ show nanos + +source :: HarmovelaSink -> String +source sink = if null (harmovelaSource sink) then "praxo-core" else harmovelaSource sink + +specVersion :: HarmovelaSink -> String +specVersion sink = if null (harmovelaSpecVersion sink) then "0.2" else harmovelaSpecVersion sink + +formatHarmovelaTimestamp :: Integer -> String +formatHarmovelaTimestamp nanos = + let (seconds, fraction) = nanos `divMod` 1000000000 + (days, daySeconds) = seconds `divMod` 86400 + (year, month, day) = civilFromDays days + hour = daySeconds `div` 3600 + minute = (daySeconds `mod` 3600) `div` 60 + second = daySeconds `mod` 60 + in pad 4 year ++ "-" ++ pad 2 month ++ "-" ++ pad 2 day ++ "T" ++ + pad 2 hour ++ ":" ++ pad 2 minute ++ ":" ++ pad 2 second ++ "." ++ + pad 9 fraction ++ "Z" + +civilFromDays :: Integer -> (Integer, Integer, Integer) +civilFromDays offset = + let z = offset + 719468 + era = if z >= 0 then z `div` 146097 else (z - 146096) `div` 146097 + doe = z - era * 146097 + yoe = (doe - doe `div` 1460 + doe `div` 36524 - doe `div` 146096) `div` 365 + year = yoe + era * 400 + doy = doe - (365 * yoe + yoe `div` 4 - yoe `div` 100) + mp = (5 * doy + 2) `div` 153 + day = doy - (153 * mp + 2) `div` 5 + 1 + month = if mp < 10 then mp + 3 else mp - 9 + in (if month <= 2 then year + 1 else year, month, day) + +pad :: Int -> Integer -> String +pad width value = + let text = show value + in replicate (max 0 (width - length text)) '0' ++ text + +trimSlash :: String -> String +trimSlash = reverse . dropWhile (== '/') . reverse + +bounded :: String -> String +bounded text = + let trimmed = trim text + in if length trimmed > 512 then take 512 trimmed else trimmed + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd predicate = reverse . dropWhile predicate . reverse diff --git a/src/Praxo/Json.hs b/src/Praxo/Json.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Json.hs @@ -0,0 +1,149 @@ +module Praxo.Json (Json(..), parseJson, encodeJson, equalJson, field, asString, asArray, asObject) where + +import Control.Monad (guard) +import Data.Char (chr, digitToInt, isDigit, isHexDigit, ord) +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Data.Ratio (denominator, numerator, (%)) +import Numeric (showHex) +import Text.ParserCombinators.ReadP + +data Json = JObject [(String, Json)] | JArray [Json] | JString String | JNumber Rational | JBool Bool | JNull deriving (Eq, Show) + +field :: String -> Json -> Json +field name (JObject fields) = maybe JNull id (lookup name (reverse fields)) +field _ _ = JNull + +asString :: Json -> String +asString (JString value) = value +asString _ = "" + +asArray :: Json -> [Json] +asArray (JArray values) = values +asArray _ = [] + +asObject :: Json -> [(String, Json)] +asObject (JObject fields) = fields +asObject _ = [] + +equalJson :: Json -> Json -> Bool +equalJson (JObject a) (JObject b) = + let left = Map.fromList a + right = Map.fromList b + in Map.keys left == Map.keys right && and (zipWith equalJson (Map.elems left) (Map.elems right)) +equalJson (JArray a) (JArray b) = length a == length b && and (zipWith equalJson a b) +equalJson a b = a == b + +parseJson :: String -> Either String Json +parseJson input + | length input > 1048576 = Left "JSON_CAPACITY" + | otherwise = case readP_to_S (space *> value 0 <* space <* eof) input of + [(result, "")] -> Right result + _ -> Left "JSON_INVALID" + where + space = skipMany (satisfy (`elem` " \t\r\n")) + token parser = parser <* space + value :: Int -> ReadP Json + value depth = do + guard (depth <= 64) + choice + [ JObject <$> between (token (char '{')) (char '}') + (sepBy ((,) <$> token stringValue <* token (char ':') <*> token (value (depth + 1))) (token (char ','))) + , JArray <$> between (token (char '[')) (char ']') + (sepBy (token (value (depth + 1))) (token (char ','))) + , JString <$> stringValue + , JBool True <$ string "true" + , JBool False <$ string "false" + , JNull <$ string "null" + , JNumber <$> numberValue + ] + +stringValue :: ReadP String +stringValue = between (char '"') (char '"') (many character) + where + character = satisfy (\c -> c /= '"' && c /= '\\' && ord c >= 32 && scalar c) <++ escaped + escaped = do + _ <- char '\\' + code <- get + case lookup code [('"', '"'), ('\\', '\\'), ('/', '/'), ('b', '\b'), ('f', '\f'), ('n', '\n'), ('r', '\r'), ('t', '\t')] of + Just result -> pure result + Nothing -> do + guard (code == 'u') + first <- hexUnit + if first >= 0xD800 && first <= 0xDBFF then do + _ <- string "\\u" + second <- hexUnit + guard (second >= 0xDC00 && second <= 0xDFFF) + pure (chr (0x10000 + (first - 0xD800) * 1024 + second - 0xDC00)) + else do + guard (first < 0xD800 || first > 0xDFFF) + pure (chr first) + hexUnit = foldl (\n c -> n * 16 + digitToInt c) 0 <$> count 4 (satisfy isHexDigit) + +scalar :: Char -> Bool +scalar c = ord c < 0xD800 || ord c > 0xDFFF + +numberValue :: ReadP Rational +numberValue = do + sign <- option 1 (-1 <$ char '-') + whole <- string "0" <++ ((:) <$> satisfy (`elem` ['1'..'9']) <*> munch isDigit) + fraction <- option "" (char '.' *> munch1 isDigit) + power <- option 0 $ do + _ <- satisfy (`elem` "eE") + direction <- option 1 ((-1 <$ char '-') <++ (1 <$ char '+')) + digits <- munch1 isDigit + guard (length digits <= 4) + pure (direction * read digits) + guard (length whole + length fraction <= 4096 && abs power <= 4096) + let coefficient = sign * read (whole ++ fraction) + scale = power - length fraction + pure (if scale >= 0 then (coefficient * 10 ^ scale) % 1 else coefficient % (10 ^ negate scale)) + +encodeJson :: Json -> Either String String +encodeJson value = do + text <- render 0 value + if length text > 1048576 then Left "JSON_CAPACITY" else Right text + where + render :: Int -> Json -> Either String String + render depth _ | depth > 64 = Left "JSON_CAPACITY" + render depth (JObject fields) = do + entries <- mapM (\(key, item) -> do + name <- quoted key + body <- render (depth + 1) item + pure (name ++ ":" ++ body)) fields + pure ("{" ++ intercalate "," entries ++ "}") + render depth (JArray items) = do + entries <- mapM (render (depth + 1)) items + pure ("[" ++ intercalate "," entries ++ "]") + render _ (JString text) = quoted text + render _ (JNumber number) = decimal number + render _ (JBool flag) = Right (if flag then "true" else "false") + render _ JNull = Right "null" + quoted text + | length text > 1048576 = Left "JSON_CAPACITY" + | not (all scalar text) = Left "JSON_INVALID" + | otherwise = Right ('"' : concatMap escape text ++ "\"") + escape '"' = "\\\"" + escape '\\' = "\\\\" + escape c | ord c < 32 = let digits = showHex (ord c) "" in "\\u" ++ replicate (4 - length digits) '0' ++ digits + escape c = [c] + +decimal :: Rational -> Either String String +decimal number = do + let n = abs (numerator number) + d = denominator number + remove factor rest | rest `mod` factor == 0 = remove factor (rest `div` factor) + | otherwise = rest + if remove 5 (remove 2 d) /= 1 then Left "JSON_NON_DECIMAL_NUMBER" else do + tailDigits <- fractional 0 (n `mod` d) d + let text = (if number < 0 then "-" else "") ++ show (n `div` d) ++ + (if null tailDigits then "" else '.' : tailDigits) + if length text > 16384 then Left "JSON_CAPACITY" else Right text + where + fractional :: Int -> Integer -> Integer -> Either String String + fractional _ 0 _ = Right "" + fractional countDigits _ _ | countDigits >= 8192 = Left "JSON_CAPACITY" + fractional countDigits rest divisor = do + let (digit, remaining) = (rest * 10) `divMod` divisor + suffix <- fractional (countDigits + 1) remaining divisor + pure (chr (ord '0' + fromInteger digit) : suffix) diff --git a/src/Praxo/JsonSchema.hs b/src/Praxo/JsonSchema.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/JsonSchema.hs @@ -0,0 +1,92 @@ +module Praxo.JsonSchema (ValidationError(..), validateSchema) where + +import Data.List (sortOn) +import Data.Ratio (denominator) +import Praxo.Json +import Praxo.Pattern + +data ValidationError = ValidationError { errorPath :: String, errorMessage :: String } deriving (Eq, Show) + +validateSchema :: Json -> Json -> Either String [ValidationError] +validateSchema schema = validate 0 "$" schema + where + validate :: Int -> String -> Json -> Json -> Either String [ValidationError] + validate depth path definition value + | depth > 64 = Left "SCHEMA_CAPACITY" + | otherwise = case definition of + JObject _ -> do + checkShape depth definition + let kind = asString (field "type" definition) + if kind `notElem` ["", "object", "array", "string", "number", "integer", "boolean", "null"] + then Left "SCHEMA_TYPE_UNSUPPORTED" + else if not (matches kind value) then pure [ValidationError path ("expected " ++ kind)] else do + details <- case value of + JObject properties -> do + required <- mapM (requiredProperty value path) (asArray (field "required" definition)) + children <- mapM (child depth path value properties) (sortOn fst (asObject (field "properties" definition))) + pure (concat required ++ concat children) + JArray items -> do + children <- case field "items" definition of + JNull -> Right [] + itemSchema -> concat <$> mapM (\(index, item) -> validate (depth + 1) (path ++ "[" ++ show index ++ "]") itemSchema item) (zip [0 :: Int ..] items) + pure (bounds definition path "minItems" "maxItems" (fromIntegral (length items)) ++ children) + JString text -> do + patternErrors <- case field "pattern" definition of + JNull -> Right [] + JString patternText -> do + valid <- matchPattern patternText text + pure [ValidationError path "pattern mismatch" | not valid] + _ -> Left "SCHEMA_INVALID_PATTERN" + pure (bounds definition path "minLength" "maxLength" (fromIntegral (length text)) ++ patternErrors) + JNumber number -> pure (bounds definition path "minimum" "maximum" number) + _ -> pure [] + let choices = asArray (field "enum" definition) + enumErrors = [ValidationError path "not in enum" | not (null choices) && not (any (equalJson value) choices)] + pure (enumErrors ++ details) + _ -> Left "SCHEMA_INVALID" + requiredProperty value path (JString key) + | key `elem` map fst (asObject value) = Right [] + | otherwise = Right [ValidationError (path ++ "." ++ key) "required"] + requiredProperty _ _ _ = Left "SCHEMA_INVALID_REQUIRED" + child depth path value properties (key, definition) + | key `elem` map fst properties = validate (depth + 1) (path ++ "." ++ key) definition (field key value) + | otherwise = Right [] + matches "" _ = True + matches "object" (JObject _) = True + matches "array" (JArray _) = True + matches "string" (JString _) = True + matches "number" (JNumber _) = True + matches "integer" (JNumber number) = denominator number == 1 + matches "boolean" (JBool _) = True + matches "null" JNull = True + matches _ _ = False + bounds definition path low high number = + [ValidationError path "below minimum" | JNumber limit <- [field low definition], limit /= 0, number < limit] ++ + [ValidationError path "above maximum" | JNumber limit <- [field high definition], limit /= 0, number > limit] + checkShape level _ | level > 64 = Left "SCHEMA_CAPACITY" + checkShape level definition = mapM_ (checkField level) (asObject definition) + checkField level (key, value) + | key `elem` ["type", "description", "pattern"] = case value of + JString _ -> Right () + _ -> Left ("SCHEMA_INVALID_FIELD:" ++ key) + | key `elem` ["minimum", "maximum"] = case value of + JNumber _ -> Right () + _ -> Left ("SCHEMA_INVALID_FIELD:" ++ key) + | key `elem` ["minLength", "maxLength", "minItems", "maxItems"] = case value of + JNumber limit | denominator limit == 1 && limit >= 0 -> Right () + _ -> Left ("SCHEMA_INVALID_FIELD:" ++ key) + | key == "required" = case value of + JArray values | all isString values -> Right () + _ -> Left "SCHEMA_INVALID_REQUIRED" + | key == "properties" = case value of + JObject values -> mapM_ (checkDefinition (level + 1) . snd) values + _ -> Left "SCHEMA_INVALID_PROPERTIES" + | key == "items" = checkDefinition (level + 1) value + | key == "enum" = case value of + JArray _ -> Right () + _ -> Left "SCHEMA_INVALID_ENUM" + | otherwise = Right () + checkDefinition level value@(JObject _) = checkShape level value + checkDefinition _ _ = Left "SCHEMA_INVALID" + isString (JString _) = True + isString _ = False diff --git a/src/Praxo/Middleware.hs b/src/Praxo/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Middleware.hs @@ -0,0 +1,217 @@ +module Praxo.Middleware + ( piiRedact, redactValue, extractJson, StructuredOutput(..), structuredOutput, applyStructured + , CallLimit(..), callLimit, callLimitModel, callLimitTool + , toolSelection, selectTools, checkToolSelected + , fallbackGenerate, fallbackEither + ) where + +import Data.Char (isAlphaNum, isDigit, isLetter) +import Data.List (findIndex) +import Praxo.Json (Json(..), parseJson) +import Praxo.JsonSchema (validateSchema) + +piiRedact :: String -> String +piiRedact = redactPhone . redactCard . redactSsn . redactEmails + +redactEmails :: String -> String +redactEmails text = go 0 "" + where + n = length text + go cursor output + | cursor >= n = output ++ drop cursor text + | otherwise = case findIndex (== '@') (drop cursor text) of + Nothing -> output ++ drop cursor text + Just offset -> + let at = cursor + offset + first = expandLeft at + endPos = expandRight (at + 1) + dots = [i | i <- [at + 1 .. endPos - 1], atChar i == '.'] + dot = if null dots then 0 else last dots + suffix = expandLetters (dot + 1) endPos + in if first < at && dot > at + 1 && suffix - dot - 1 >= 2 + then go suffix (output ++ take (first - cursor) (drop cursor text) ++ "[REDACTED:email]") + else go (at + 1) (output ++ take (at - cursor + 1) (drop cursor text)) + atChar i = text !! i + expandLeft i = if i > 0 && atChar (i - 1) `elem` emailLocal then expandLeft (i - 1) else i + expandRight i = if i < n && atChar i `elem` emailDomain then expandRight (i + 1) else i + expandLetters i limit = if i < limit && isLetter (atChar i) then expandLetters (i + 1) limit else i + emailLocal = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "._%+-" + emailDomain = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".-" + +redactSsn :: String -> String +redactSsn = replaceMatches match "[REDACTED:ssn]" + where + match i text + | i + 10 < length text && boundaryLeft i text && digitsAt i 3 text + && atChar (i + 3) text == '-' && digitsAt (i + 4) 2 text + && atChar (i + 6) text == '-' && digitsAt (i + 7) 4 text + && boundaryRight (i + 10) text = Just (i + 10) + | otherwise = Nothing + atChar i text = text !! i + boundaryLeft i text = i == 0 || not (isWord (text !! (i - 1))) + boundaryRight i text = i >= length text - 1 || not (isWord (text !! (i + 1))) + digitsAt i count text = i >= 0 && i + count <= length text && all isDigit (take count (drop i text)) + isWord c = isAlphaNum c || c == '_' + +redactCard :: String -> String +redactCard = replaceMatches match "[REDACTED:credit_card]" + where + match i text + | boundaryLeft i text = case parseGroups i text of + Just finish | boundaryRight finish text -> Just finish + _ -> Nothing + | otherwise = Nothing + parseGroups i text = go i (1 :: Int) + where + go position group + | group > 4 = Just (position - 1) + | not (digitsAt position 4 text) = Nothing + | otherwise = + let next = position + 4 + after = if group < 4 && next < length text && text !! next `elem` " -" then next + 1 else next + in go after (group + 1) + digitsAt i count text = i + count <= length text && all isDigit (take count (drop i text)) + boundaryLeft i text = i == 0 || not (isWord (text !! (i - 1))) + boundaryRight i text = i >= length text - 1 || not (isWord (text !! (i + 1))) + isWord c = isAlphaNum c || c == '_' + +redactPhone :: String -> String +redactPhone = replaceMatches match "[REDACTED:phone]" + where + match i text + | not (boundaryLeft i text) = Nothing + | otherwise = case [finish | Just finish <- candidates, boundaryRightAt text finish] of + (finish:_) -> Just finish + [] -> Nothing + where + candidates = + [parseBody i text] ++ + [parseBody (skipSeparator (i + 1) text) text | atChar i text == '1'] ++ + [parseBody (skipSeparator (i + 2) text) text | take 2 (drop i text) == "+1"] + parseBody start text = go start + where + go position + | position > length text = Nothing + | position < length text && text !! position == '(' = + if digitsAt (position + 1) 3 text && position + 4 < length text && text !! (position + 4) == ')' + then finish (position + 5) + else Nothing + | digitsAt position 3 text = finish (position + 3) + | otherwise = Nothing + finish position = + let p1 = skipSeparator position text + in if digitsAt p1 3 text + then let p2 = skipSeparator (p1 + 3) text + in if digitsAt p2 4 text then Just (p2 + 3) else Nothing + else Nothing + digitsAt i count text = i >= 0 && i + count <= length text && all isDigit (take count (drop i text)) + atChar i text = if i < length text then text !! i else '\0' + skipSeparator i text = if i < length text && text !! i `elem` " -." then i + 1 else i + boundaryLeft i text = i == 0 || not (isWord (text !! (i - 1))) + boundaryRightAt text finish = finish >= length text - 1 || not (isWord (text !! (finish + 1))) + isWord c = isAlphaNum c || c == '_' + +replaceMatches :: (Int -> String -> Maybe Int) -> String -> String -> String +replaceMatches match replacement text = go 0 "" + where + n = length text + go cursor output + | cursor >= n = output + | Just finish <- match cursor text = go (finish + 1) (output ++ replacement) + | otherwise = go (cursor + 1) (output ++ [text !! cursor]) + + +redactValue :: Json -> Json +redactValue (JString text) = JString (piiRedact text) +redactValue (JArray values) = JArray (map redactValue values) +redactValue (JObject fields) = JObject [(key, redactValue value) | (key, value) <- fields] +redactValue value = value + +extractJson :: String -> Maybe Json +extractJson text = + let trimmed = trim text + stripped = if take 3 trimmed == "```" then trim (stripFence trimmed) else trimmed + in case findIndex (`elem` "{[" ) stripped of + Nothing -> Nothing + Just start -> either (const Nothing) Just (parseJson (drop start stripped)) + +stripFence :: String -> String +stripFence text = case break (== '\n') text of + (_, '\n':rest) -> reverse (dropWhile (== '\n') (reverse rest)) + _ -> text + +trim :: String -> String +trim = reverse . dropWhile (`elem` " \t\r\n") . reverse . dropWhile (`elem` " \t\r\n") + +data StructuredOutput = StructuredOutput + { outputSchema :: Json + , maxRepairs :: Int + , repairer :: Maybe (String -> Either String String) + } + +structuredOutput :: Json -> Int -> Maybe (String -> Either String String) -> StructuredOutput +structuredOutput = StructuredOutput + +applyStructured :: StructuredOutput -> String -> Either String String +applyStructured config = attempt 0 + where + attempt count text = + case extractJson text of + Just value | either (const False) null (validateSchema (outputSchema config) value) -> Right text + _ | count >= maxRepairs config -> Left "AGENT_STRUCTURED_OUTPUT" + _ -> case repairer config of + Nothing -> Left "AGENT_STRUCTURED_OUTPUT" + Just repair -> case repair text of + Left errorCode -> Left errorCode + Right repaired + | null (trim repaired) -> Left "AGENT_STRUCTURED_OUTPUT" + | otherwise -> attempt (count + 1) repaired + +data CallLimit = CallLimit + { limitModel :: Int + , limitTool :: Int + , modelsCalled :: Int + , toolsCalled :: Int + } deriving (Eq, Show) + +callLimit :: Int -> Int -> CallLimit +callLimit model tool = CallLimit model tool 0 0 + +callLimitModel :: CallLimit -> Either String CallLimit +callLimitModel limit = + let updated = limit { modelsCalled = modelsCalled limit + 1 } + in if limitModel limit > 0 && modelsCalled updated > limitModel limit + then Left "AGENT_MODEL_CALL_LIMIT" + else Right updated + +callLimitTool :: CallLimit -> Either String CallLimit +callLimitTool limit = + let updated = limit { toolsCalled = toolsCalled limit + 1 } + in if limitTool limit > 0 && toolsCalled updated > limitTool limit + then Left "AGENT_TOOL_CALL_LIMIT" + else Right updated + +type ToolSelection = [String] + +toolSelection :: [String] -> ToolSelection +toolSelection = id + +selectTools :: ToolSelection -> [String] -> [String] +selectTools selection = filter (`elem` selection) + +checkToolSelected :: ToolSelection -> String -> Either String () +checkToolSelected selection name + | name `elem` selection = Right () + | otherwise = Left "AGENT_TOOL_NOT_SELECTED" + +fallbackEither :: Either e a -> Either e a -> Either e a +fallbackEither primary fallback = case primary of + Left _ -> fallback + Right _ -> primary + +fallbackGenerate :: IO (Either e a) -> IO (Either e a) -> IO (Either e a) +fallbackGenerate primary fallback = do + result <- primary + case result of + Left _ -> fallback + Right _ -> pure result diff --git a/src/Praxo/OpenAICompatible.hs b/src/Praxo/OpenAICompatible.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/OpenAICompatible.hs @@ -0,0 +1,171 @@ +module Praxo.OpenAICompatible + ( HttpRequest(..) + , HttpResponse(..) + , Transport(..) + , OpenAITool(..) + , OpenAIConfig(..) + , buildRequest + , parseResponse + , generate + ) where + +import Praxo.Agent (AgentError(..), Message(..), Response(..), ToolCall(..)) +import Praxo.Json (Json(..), asArray, asString, encodeJson, field, parseJson) + +data HttpRequest = HttpRequest + { httpMethod :: String + , httpURL :: String + , httpHeaders :: [(String, String)] + , httpBody :: String + } deriving (Eq, Show) + +data HttpResponse = HttpResponse + { httpStatus :: Int + , httpResponseBody :: String + } deriving (Eq, Show) + +newtype Transport = Transport + { sendTransport :: HttpRequest -> IO (Either AgentError HttpResponse) + } + +data OpenAITool = OpenAITool + { openAIToolName :: String + , openAIToolDescription :: String + , openAIToolParameters :: Json + } deriving (Eq, Show) + +data OpenAIConfig = OpenAIConfig + { openAIBaseURL :: String + , openAIModel :: String + , openAIKey :: Maybe String + , openAIToolChoice :: Maybe String + , openAITools :: [OpenAITool] + , openAITransport :: Transport + } + +buildRequest :: OpenAIConfig -> [Message] -> Either AgentError HttpRequest +buildRequest config messages + | null (openAIBaseURL config) = Left (AgentError "PROVIDER_HTTP" "provider base URL is required") + | otherwise = do + encoded <- mapM messageJson messages + let toolValues = map toolJson (openAITools config) + base = + [ ("model", JString (openAIModel config)) + , ("messages", JArray encoded) + ] + withTools = if null toolValues then base else base ++ [("tools", JArray toolValues)] + withChoice = case openAIToolChoice config of + Nothing -> withTools + Just choice -> withTools ++ [("tool_choice", JString choice)] + case encodeJson (JObject withChoice) of + Left detail -> Left (AgentError "PROVIDER_REQUEST" detail) + Right text -> + Right HttpRequest + { httpMethod = "POST" + , httpURL = trimSlash (openAIBaseURL config) ++ "/chat/completions" + , httpHeaders = + [ ("Content-Type", "application/json") + , ("Accept", "application/json") + ] ++ case openAIKey config of + Nothing -> [] + Just key -> [("Authorization", "Bearer " ++ key)] + , httpBody = text + } + where + trimSlash = reverse . dropWhile (== '/') . reverse + +parseResponse :: String -> Either AgentError Response +parseResponse text = do + root <- case parseJson text of + Left detail -> Left (AgentError "PROVIDER_RESPONSE" ("provider returned invalid JSON: " ++ detail)) + Right value -> Right value + case asArray (field "choices" root) of + [] -> Left (AgentError "PROVIDER_RESPONSE" "provider response has no choices") + choice : _ -> do + let message = field "message" choice + calls <- mapM callFromJson (asArray (field "tool_calls" message)) + let usage = field "usage" root + pure Response + { responseContent = asString (field "content" message) + , responseToolCalls = calls + , inputTokens = jsonInteger (field "prompt_tokens" usage) + , outputTokens = jsonInteger (field "completion_tokens" usage) + } + where + callFromJson item = do + let function = field "function" item + arguments <- case field "arguments" function of + JString raw | not (null raw) -> case parseJson raw of + Left detail -> Left (AgentError "PROVIDER_RESPONSE" ("tool arguments are not valid JSON: " ++ detail)) + Right value@(JObject _) -> Right value + Right _ -> Left (AgentError "PROVIDER_RESPONSE" "tool arguments must be an object") + value@(JObject _) -> Right value + _ -> Right (JObject []) + pure ToolCall + { toolCallId = asString (field "id" item) + , toolCallName = asString (field "name" function) + , toolCallArguments = arguments + } + +generate :: OpenAIConfig -> [Message] -> IO (Either AgentError Response) +generate config messages = + case buildRequest config messages of + Left errorValue -> pure (Left errorValue) + Right httpRequest -> do + result <- sendTransport (openAITransport config) httpRequest + pure $ case result of + Left errorValue -> Left errorValue + Right response + | httpStatus response < 200 || httpStatus response >= 300 -> + Left (AgentError "PROVIDER_HTTP" + ("provider returned HTTP " ++ show (httpStatus response) ++ ": " ++ bounded (httpResponseBody response))) + | otherwise -> parseResponse (httpResponseBody response) + +messageJson :: Message -> Either AgentError Json +messageJson message = do + calls <- mapM callJson (messageToolCalls message) + let base = + [ ("role", JString (messageRole message)) + , ("content", JString (messageContent message)) + ] + withCalls = if null calls then base else base ++ [("tool_calls", JArray calls)] + withTool = + if messageRole message == "tool" && messageToolCallId message /= "" + then withCalls ++ [("tool_call_id", JString (messageToolCallId message))] + else withCalls + pure (JObject withTool) + where + callJson call = do + arguments <- case encodeJson (toolCallArguments call) of + Left detail -> Left (AgentError "PROVIDER_REQUEST" ("tool arguments: " ++ detail)) + Right text -> Right text + pure (JObject + [ ("id", JString (toolCallId call)) + , ("type", JString "function") + , ("function", JObject + [ ("name", JString (toolCallName call)) + , ("arguments", JString arguments) + ]) + ]) + +toolJson :: OpenAITool -> Json +toolJson tool = + JObject + [ ("type", JString "function") + , ("function", JObject + [ ("name", JString (openAIToolName tool)) + , ("description", JString (openAIToolDescription tool)) + , ("parameters", parameters) + ]) + ] + where + parameters = case openAIToolParameters tool of + JNull -> JObject [("type", JString "object")] + value -> value + +jsonInteger :: Json -> Integer +jsonInteger (JNumber value) = truncate value +jsonInteger _ = 0 + +bounded :: String -> String +bounded text = if length text > 512 then take 512 text else text diff --git a/src/Praxo/Pattern.hs b/src/Praxo/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Pattern.hs @@ -0,0 +1,79 @@ +module Praxo.Pattern (matchPattern) where + +import Data.Char (isAscii, isDigit, isSpace) +import qualified Data.IntSet as Set +import qualified Data.IntMap.Strict as Map + +type Token = (Char -> Bool, Char) + +matchPattern :: String -> String -> Either String Bool +matchPattern patternText input + | length patternText > 256 || (toInteger (length patternText) + 1) * (toInteger (length input) + 1) ^ (2 :: Int) > 2000000 = Left "SCHEMA_PATTERN_CAPACITY" + | not (all isAscii patternText) = Left "SCHEMA_PATTERN_UNSUPPORTED" + | otherwise = do + let (atStart, body) = case patternText of '^':rest -> (True, rest); _ -> (False, patternText) + (tokens, atEnd) <- compile body + let initial = if atStart then Set.singleton 0 else Set.fromList [0..length input] + result = foldl transition initial tokens + pure (if atEnd then Set.member inputSize result else not (Set.null result)) + where + inputSize = length input + characters = Map.fromList (zip [0..] input) + transition positions (predicate, quantifier) = Set.fromList + [end | start <- Set.toList positions, end <- consume predicate quantifier start] + consume predicate quantifier start = + let ends = takeWhile (\end -> end <= inputSize && (end == start || predicate (characters Map.! (end - 1)))) [start..] + in case quantifier of + '*' -> ends + '+' -> drop 1 ends + '?' -> take 2 ends + _ -> take 1 (drop 1 ends) + +compile :: String -> Either String ([Token], Bool) +compile [] = Right ([], False) +compile "$" = Right ([], True) +compile text = do + (predicate, rest) <- atom text + let (quantifier, remaining) = case rest of + first:suffix | first `elem` "*+?" -> (first, suffix) + _ -> ('1', rest) + (tokens, atEnd) <- compile remaining + pure ((predicate, quantifier) : tokens, atEnd) + +atom :: String -> Either String (Char -> Bool, String) +atom ('.':rest) = Right ((/= '\n'), rest) +atom ('\\':code:rest) = do + predicate <- escaped code + pure (predicate, rest) +atom ('[':rest) = do + let (negative, body) = case rest of '^':suffix -> (True, suffix); _ -> (False, rest) + (predicates, remaining) <- characterClass body + if null predicates then Left "SCHEMA_PATTERN_UNSUPPORTED" else + Right ((\c -> any ($ c) predicates /= negative), remaining) +atom (first:rest) + | first `elem` "^$[](){}|*+?\\" = Left "SCHEMA_PATTERN_UNSUPPORTED" + | otherwise = Right ((== first), rest) +atom [] = Left "SCHEMA_PATTERN_UNSUPPORTED" + +escaped :: Char -> Either String (Char -> Bool) +escaped 'd' = Right isDigit +escaped 'w' = Right (\c -> isAscii c && (c `elem` ['a'..'z'] || c `elem` ['A'..'Z'] || isDigit c || c == '_')) +escaped 's' = Right (\c -> isAscii c && isSpace c) +escaped code + | code `elem` ".^$[](){}|*+?\\-" = Right (== code) + | otherwise = Left "SCHEMA_PATTERN_UNSUPPORTED" + +characterClass :: String -> Either String ([Char -> Bool], String) +characterClass (']':rest) = Right ([], rest) +characterClass ('\\':code:rest) = do + predicate <- escaped code + (others, remaining) <- characterClass rest + pure (predicate : others, remaining) +characterClass (low:'-':high:rest) | high /= ']' = do + if low > high || low == '\\' || high == '\\' then Left "SCHEMA_PATTERN_UNSUPPORTED" else do + (others, remaining) <- characterClass rest + pure ((\c -> c >= low && c <= high) : others, remaining) +characterClass (first:rest) = do + (others, remaining) <- characterClass rest + pure ((== first) : others, remaining) +characterClass [] = Left "SCHEMA_PATTERN_UNSUPPORTED" diff --git a/src/Praxo/Plugin.hs b/src/Praxo/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Plugin.hs @@ -0,0 +1,159 @@ +module Praxo.Plugin (parseManifest, validateManifest) where + +import Control.Monad (unless) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import qualified Data.Set as Set +import Data.Ratio (denominator) +import Praxo.Json + +parseManifest :: String -> Either String Json +parseManifest raw = do + manifest <- parseJson raw + validateManifest manifest + pure manifest + +validateManifest :: Json -> Either String () +validateManifest manifest = do + strictObject topKeys manifest + unless (all (`elem` map fst (asObject manifest)) requiredKeys) (Left "PLUGIN_MISSING_FIELD") + unless (field "schemaVersion" manifest == JNumber 1) (Left "PLUGIN_SCHEMA_VERSION") + identifier <- requiredString "id" manifest + let labels = split '.' identifier + unless (length labels >= 2 && all validLabel labels) (Left "PLUGIN_INVALID_ID") + version <- requiredString "version" manifest + unless (validVersion version) (Left "PLUGIN_INVALID_VERSION") + kind <- requiredString "kind" manifest + unless (kind `elem` [name ++ ".provider.v1" | name <- ["tool", "model", "policy", "memory", "sandbox"]]) (Left "PLUGIN_INVALID_KIND") + protocol <- requiredString "protocol" manifest + unless (protocol == "jsonrpc-2") (Left "PLUGIN_INVALID_PROTOCOL") + let entrypoint = field "entrypoint" manifest + strictObject ["type", "command", "module", "image", "args", "dir"] entrypoint + launchType <- requiredString "type" entrypoint + target <- case lookup launchType [("process", "command"), ("wasm", "module"), ("container", "image")] of + Nothing -> Left "PLUGIN_INVALID_ENTRYPOINT" + Just key -> requiredString key entrypoint + unless (not (null target)) (Left "PLUGIN_INVALID_ENTRYPOINT") + mapM_ (optionalString entrypoint) ["command", "module", "image", "dir"] + optionalStrings entrypoint "args" + isolation <- requiredString "isolation" manifest + unless (isolation == launchType) (Left "PLUGIN_INVALID_ISOLATION") + capabilities <- strings (field "capabilities" manifest) + unless (all (not . null) capabilities && length capabilities == Set.size (Set.fromList capabilities)) (Left "PLUGIN_INVALID_CAPABILITIES") + permissions (field "permissions" manifest) + nonnegative ["memoryMB", "cpuMillis", "timeoutMs", "maxInflight"] (field "limits" manifest) + let health = field "health" manifest + strictObject ["method", "intervalMs"] health + optionalString health "method" + interval <- optionalInteger health "intervalMs" + unless (interval >= 0 && (interval == 0 || not (null (asString (field "method" health))))) (Left "PLUGIN_INVALID_HEALTH") + case field "signature" manifest of + JNull -> pure () + signature -> do + strictObject ["algorithm", "keyId"] signature + _ <- requiredString "algorithm" signature + _ <- requiredString "keyId" signature + pure () + optionalString manifest "sbom" + let sbom = asString (field "sbom" manifest) + unless (null sbom || relativePath sbom) (Left "PLUGIN_INVALID_SBOM") + where + requiredKeys = ["schemaVersion", "id", "version", "kind", "entrypoint", "protocol", "capabilities", "permissions", "limits", "health", "isolation"] + topKeys = requiredKeys ++ ["signature", "sbom"] + +strictObject :: [String] -> Json -> Either String () +strictObject allowed (JObject fields) = do + unless (all ((`elem` allowed) . fst) fields) (Left "PLUGIN_UNKNOWN_FIELD") + unless (length fields == Set.size (Set.fromList (map fst fields))) (Left "PLUGIN_DUPLICATE_FIELD") +strictObject _ _ = Left "PLUGIN_EXPECTED_OBJECT" + +requiredString :: String -> Json -> Either String String +requiredString key object = case field key object of + JString value | not (null value) -> Right value + _ -> Left ("PLUGIN_INVALID_STRING:" ++ key) + +optionalString :: Json -> String -> Either String () +optionalString object key + | key `notElem` map fst (asObject object) = Right () + | otherwise = case field key object of + JString _ -> Right () + _ -> Left ("PLUGIN_INVALID_STRING:" ++ key) + +strings :: Json -> Either String [String] +strings (JArray values) = mapM stringItem values + where + stringItem (JString text) = Right text + stringItem _ = Left "PLUGIN_EXPECTED_STRING" +strings _ = Left "PLUGIN_EXPECTED_ARRAY" + +optionalStrings :: Json -> String -> Either String () +optionalStrings object key + | key `notElem` map fst (asObject object) = Right () + | otherwise = strings (field key object) >> pure () + +optionalInteger :: Json -> String -> Either String Integer +optionalInteger object key + | key `notElem` map fst (asObject object) = Right 0 + | otherwise = case field key object of + JNumber value | denominator value == 1 -> Right (round value) + _ -> Left ("PLUGIN_INVALID_INTEGER:" ++ key) + +nonnegative :: [String] -> Json -> Either String () +nonnegative keys object = do + strictObject keys object + values <- mapM (optionalInteger object) keys + unless (all (>= 0) values) (Left "PLUGIN_NEGATIVE_LIMIT") + +permissions :: Json -> Either String () +permissions object = do + strictObject ["filesystem", "network", "env"] object + optionalStrings object "env" + env <- if field "env" object == JNull then Right [] else strings (field "env" object) + unless (all validEnv env) (Left "PLUGIN_INVALID_ENV") + entries "filesystem" object $ \entry -> do + strictObject ["path", "mode"] entry + path <- requiredString "path" entry + mode <- requiredString "mode" entry + unless (mode `elem` ["read", "write", "readwrite"] && ".." `notElem` split '/' (slashes path)) (Left "PLUGIN_INVALID_FILESYSTEM") + entries "network" object $ \entry -> do + strictObject ["host", "port"] entry + _ <- requiredString "host" entry + port <- optionalInteger entry "port" + unless (port >= 1 && port <= 65535) (Left "PLUGIN_INVALID_NETWORK") + where + validEnv (first:rest) = (isAsciiLower first || isAsciiUpper first || first == '_') && all envChar rest + validEnv [] = False + envChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' + +entries :: String -> Json -> (Json -> Either String ()) -> Either String () +entries key object check + | key `notElem` map fst (asObject object) = Right () + | otherwise = case field key object of + JArray values -> mapM_ check values + _ -> Left "PLUGIN_EXPECTED_ARRAY" + +split :: Char -> String -> [String] +split separator text = case break (== separator) text of + (first, []) -> [first] + (first, _:rest) -> first : split separator rest + +validLabel :: String -> Bool +validLabel [] = False +validLabel label@(first:_) = alphaNumber first && alphaNumber (last label) && all (\c -> alphaNumber c || c == '-') label + where alphaNumber c = isAsciiLower c || isDigit c + +validVersion :: String -> Bool +validVersion text = + let (baseAndPre, metadata) = break (== '+') text + (base, prerelease) = break (== '-') baseAndPre + numeric [] = False + numeric part@(first:_) = all isDigit part && (part == "0" || first /= '0') + suffix [] = True + suffix (_:rest) = not (null rest) && all (\c -> isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ".-") rest + in length (split '.' base) == 3 && all numeric (split '.' base) && suffix prerelease && suffix metadata + +slashes :: String -> String +slashes = map (\c -> if c == '\\' then '/' else c) + +relativePath :: String -> Bool +relativePath [] = False +relativePath path@(first:_) = first /= '/' && first /= '\\' && ':' `notElem` path && ".." `notElem` split '/' (slashes path) diff --git a/src/Praxo/Runtime.hs b/src/Praxo/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Runtime.hs @@ -0,0 +1,265 @@ +module Praxo.Runtime + ( MemoryRecord(..), MemoryStore, newMemoryStore, memoryPut, memorySearch + , Event(..), Sink(..), newSink, multiSink, filterSink, emitSink, sinkKinds, sinkKindLists + , streamKinds + , newCheckpoint, registerCheckpoint, checkpointMarshal, checkpointUnmarshal + , PathGrant(..), PathChecker(..), Decision(..), normalizePath, pathChecker, pathCheck, pathAllowed + , ContextBudget(..), ContextMessage(..), estimateTokens, compactContext, messageWire + ) where + +import Data.Char (toLower) +import Data.List (intercalate, isInfixOf, sortBy) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Praxo.Json (Json(..), asString, encodeJson, field, parseJson) +import System.Info (os) + +data MemoryRecord = MemoryRecord + { recordId :: String + , recordFrame :: String + , recordContent :: String + , recordCreatedAt :: String + } deriving (Eq, Show) + +data MemoryStore = MemoryStore + { storeRecords :: Map String [MemoryRecord] + , storeSequence :: Int + } deriving (Eq, Show) + +newMemoryStore :: MemoryStore +newMemoryStore = MemoryStore Map.empty 0 + +memoryPut :: MemoryStore -> String -> MemoryRecord -> (MemoryStore, MemoryRecord) +memoryPut store session record = + let (withId, nextSequence) = + if null (recordId record) + then (record { recordId = "mem-" ++ show (storeSequence store) ++ "-" ++ show (length current) }, storeSequence store + 1) + else (record, storeSequence store) + withTime = if null (recordCreatedAt withId) then withId { recordCreatedAt = show nextSequence } else withId + current = Map.findWithDefault [] session (storeRecords store) + updated = store { storeRecords = Map.insert session (current ++ [withTime]) (storeRecords store), storeSequence = nextSequence } + in (updated, withTime) + +memorySearch :: MemoryStore -> String -> String -> Int -> [MemoryRecord] +memorySearch store session query limit = + let needle = map toLower query + records = Map.findWithDefault [] session (storeRecords store) + matches = filter (\record -> null needle || needle `isInfixOf` map toLower (recordContent record)) records + ordered = sortBy (flip (comparing recordCreatedAt)) matches + in if limit > 0 then take limit ordered else ordered + +data Event = Event + { eventKind :: String + , eventSessionId :: String + , eventRunId :: Maybe String + , eventData :: Json + } deriving (Eq, Show) + +data Sink = RecordSink [String] | MultiSink [Sink] | FilterSink Sink [String] deriving (Eq, Show) + +newSink :: Sink +newSink = RecordSink [] + +multiSink :: [Sink] -> Sink +multiSink = MultiSink + +filterSink :: Sink -> [String] -> Sink +filterSink = FilterSink + +emitSink :: Sink -> Event -> Sink +emitSink (MultiSink sinks) event = MultiSink (map (`emitSink` event) sinks) +emitSink (FilterSink target predicate) event + | null predicate || eventKind event `elem` predicate = FilterSink (emitSink target event) predicate + | otherwise = FilterSink target predicate +emitSink (RecordSink kinds) event = RecordSink (kinds ++ [eventKind event]) + +sinkKinds :: Sink -> [String] +sinkKinds (RecordSink kinds) = kinds +sinkKinds (FilterSink target _) = sinkKinds target +sinkKinds (MultiSink _) = [] + +sinkKindLists :: Sink -> [[String]] +sinkKindLists (MultiSink sinks) = map sinkKinds sinks +sinkKindLists sink = [sinkKinds sink] + +streamKinds :: [String] +streamKinds = ["values", "updates", "messages", "tasks", "debug", "checkpoint"] + +type CheckpointAllowlist = [String] + +newCheckpoint :: CheckpointAllowlist +newCheckpoint = [] + +registerCheckpoint :: CheckpointAllowlist -> String -> Either String CheckpointAllowlist +registerCheckpoint _ "" = Left "CHECKPOINT_ERROR" +registerCheckpoint allowlist kind = Right (allowlist ++ [kind | kind `notElem` allowlist]) + +checkpointMarshal :: CheckpointAllowlist -> String -> Json -> Either String String +checkpointMarshal allowlist kind value + | kind `elem` allowlist = encodeJson (JObject [("type", JString kind), ("data", value)]) + | otherwise = Left "CHECKPOINT_TYPE_NOT_ALLOWED" + +checkpointUnmarshal :: CheckpointAllowlist -> String -> Either String Json +checkpointUnmarshal allowlist raw = do + envelope <- either (const (Left "CHECKPOINT_ERROR")) Right (parseJson raw) + let kind = asString (field "type" envelope) + if kind `elem` allowlist + then Right (field "data" envelope) + else Left "CHECKPOINT_TYPE_NOT_ALLOWED" + +data PathGrant = PathGrant { grantRoot :: String, grantAccess :: String } deriving (Eq, Show) +newtype PathChecker = PathChecker [PathGrant] deriving (Eq, Show) +data Decision = Decision { decisionAllowed :: Bool, decisionReason :: String } deriving (Eq, Show) + +normalizePath :: String -> String +normalizePath value = + let path = map (\c -> if c == '\\' then '/' else c) value + (prefix, body, absolute) = + case path of + drive : ':' : rest -> let isAbs = take 1 rest == "/" in (drive : ":" ++ if isAbs then "/" else "", rest, isAbs) + '/' : _ -> ("/", path, True) + _ -> ("", path, False) + parts = reduce absolute (splitSlash body) + result = prefix ++ intercalate "/" parts + in if os == "mingw32" then map toLower result else result + +splitSlash :: String -> [String] +splitSlash "" = [""] +splitSlash text = case break (== '/') text of + (part, []) -> [part] + (part, _ : rest) -> part : splitSlash rest + +reduce :: Bool -> [String] -> [String] +reduce absolute = foldl step [] + where + step acc "" = acc + step acc "." = acc + step acc ".." + | null acc = if absolute then [] else [".."] + | last acc == ".." = acc ++ [".."] + | otherwise = init acc + step acc part = acc ++ [part] + +pathChecker :: [PathGrant] -> Either String PathChecker +pathChecker grants = PathChecker <$> mapM checkGrant grants + where + checkGrant grant + | null (grantRoot grant) = Left "POLICY_ERROR" + | grantAccess grant `notElem` ["read", "write", "readwrite"] = Left "POLICY_ERROR" + | otherwise = Right grant { grantRoot = normalizePath (grantRoot grant) } + +pathCheck :: PathChecker -> String -> String -> Either String Decision +pathCheck (PathChecker grants) target need + | need `notElem` ["read", "write", "readwrite"] = Left "POLICY_ERROR" + | null grants = Right (Decision False "no allowed roots") + | any matches grants = Right (Decision True "allowed") + | any (\grant -> within (grantRoot grant) resolved) grants = Right (Decision False "insufficient grant") + | otherwise = Right (Decision False "outside roots") + where + resolved = normalizePath target + matches grant = within (grantRoot grant) resolved && allows (grantAccess grant) need + within root value = root == value || (root ++ "/") `isPrefixOf` value + +allows :: String -> String -> Bool +allows "readwrite" _ = True +allows "read" "read" = True +allows "write" "write" = True +allows _ _ = False + +pathAllowed :: PathChecker -> String -> String -> Bool +pathAllowed checker target need = case pathCheck checker target need of + Right decision -> decisionAllowed decision + Left _ -> False + +isPrefixOf :: String -> String -> Bool +isPrefixOf prefix value = take (length prefix) value == prefix + +data ContextBudget = ContextBudget { budgetMaxTokens :: Int, budgetKeepRecent :: Int } deriving (Eq, Show) +data ContextMessage = ContextMessage + { messageRole :: String + , messageContent :: String + , messageBlocks :: [String] + , messageCalls :: [(String, Json)] + , messageToolId :: Maybe String + } deriving (Eq, Show) + +estimateTokens :: [ContextMessage] -> Int +estimateTokens = sum . map messageTokens + where + messageTokens message = 4 + + length (messageContent message) `div` 4 + + length (fromMaybe "" (messageToolId message)) `div` 4 + + sum [4 + length block `div` 4 | block <- messageBlocks message] + + sum [4 + length name `div` 4 + length (render arguments) `div` 4 | (name, arguments) <- messageCalls message] + render value = either (const "") id (encodeJson value) + +compactContext :: ContextBudget -> [ContextMessage] -> ([ContextMessage], Bool) +compactContext budget messages + | budgetMaxTokens budget <= 0 || estimateTokens messages <= budgetMaxTokens budget = (messages, True) + | otherwise = + let (system, rest) = partitionSystem messages + system' = filter (not . isCompaction . messageContent) system + in case fitSystem system' (budgetMaxTokens budget) of + Nothing -> ([], False) + Just fitted -> + let keep = if budgetKeepRecent budget > 0 then budgetKeepRecent budget else 4 + start = alignStart rest (max (length rest - keep) 0) + marker = ContextMessage "system" ("[context compacted: " ++ show start ++ " older messages omitted]") [] [] Nothing + kept = drop start rest + output = fitted ++ (if start > 0 then [marker] else []) ++ kept + in shrink output kept fitted marker start (budgetMaxTokens budget) + where + isCompaction value = take 19 value == "[context compacted:" + +partitionSystem :: [ContextMessage] -> ([ContextMessage], [ContextMessage]) +partitionSystem messages = (filter isSystem messages, filter (not . isSystem) messages) + where isSystem message = messageRole message == "system" + +fitSystem :: [ContextMessage] -> Int -> Maybe [ContextMessage] +fitSystem [] _ = Just [] +fitSystem system maxTokens + | estimateTokens system <= maxTokens = Just system + | otherwise = + case system of + (first:rest) -> + let trimmed = first { messageContent = truncateToTokens (messageContent first) (maxTokens - 4) } + candidate = trimmed : rest + in if estimateTokens candidate <= maxTokens then Just candidate else Nothing + +truncateToTokens :: String -> Int -> String +truncateToTokens text tokens + | tokens <= 0 = "" + | length text <= limit = text + | limit <= 16 = take limit text + | otherwise = take (limit - 16) text ++ "\n[truncated]" + where limit = tokens * 4 + +alignStart :: [ContextMessage] -> Int -> Int +alignStart _ 0 = 0 +alignStart rest start + | messageRole (rest !! start) == "tool" = alignStart rest (start - 1) + | otherwise = start + +shrink :: [ContextMessage] -> [ContextMessage] -> [ContextMessage] -> ContextMessage -> Int -> Int -> ([ContextMessage], Bool) +shrink output kept system marker start maxTokens + | estimateTokens output > maxTokens && length kept > 1 = + if messageRole (kept !! 1) == "tool" + then (output, False) + else + let kept' = drop 1 kept + output' = system ++ (if start > 0 then [marker] else []) ++ kept' + in shrink output' kept' system marker start maxTokens + | otherwise = (output, estimateTokens output <= maxTokens) + +messageWire :: ContextMessage -> Json +messageWire message = + let base = [("role", JString (messageRole message))] + content = if not (null (messageContent message)) || null (messageBlocks message) && null (messageCalls message) && messageToolId message == Nothing + then [("content", JString (messageContent message))] + else [] + blocks = if null (messageBlocks message) then [] else [("contentBlocks", JArray [JObject [("type", JString "text"), ("text", JString block)] | block <- messageBlocks message])] + calls = if null (messageCalls message) then [] else [("toolCalls", JArray [JObject [("id", JString ""), ("name", JString name), ("arguments", arguments)] | (name, arguments) <- messageCalls message])] + toolId = maybe [] (\value -> [("toolId", JString value)]) (messageToolId message) + in JObject (base ++ content ++ blocks ++ calls ++ toolId) diff --git a/src/Praxo/ToolCall.hs b/src/Praxo/ToolCall.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/ToolCall.hs @@ -0,0 +1,107 @@ +module Praxo.ToolCall (ToolCall(..), parseInputJson, parseToolCall, stripToolCallMarkup) where + +import Data.Char (isAlpha, isAlphaNum, isAscii, isSpace) +import Data.List (findIndex, isPrefixOf, isSuffixOf, stripPrefix, tails) +import Data.Maybe (mapMaybe) +import Praxo.Json + +data ToolCall = ToolCall { callName :: String, callInput :: Json, callMetadata :: [(String, String)] } deriving (Eq, Show) + +parseInputJson :: String -> Maybe Json +parseInputJson text = case parseJson (trim text) of + Right value@(JObject _) -> Just value + _ -> Nothing + +parseToolCall :: String -> Maybe ToolCall +parseToolCall content | length content > 262144 = Nothing +parseToolCall content = case parseJson content of + Right object@(JObject _) | not (null (asString (field "name" object))) -> do + let arguments = field "input" object + metadataKeys = ["operation", "resource", "risk", "reason", "idempotency_key"] + stringField key = case field key object of JString _ -> True; JNull -> True; _ -> False + if not (all stringField metadataKeys) then Nothing else case arguments of + JObject _ -> fromObject object arguments + JNull -> fromObject object JNull + _ -> Nothing + _ -> case reverse (blocks content) of + block:_ -> blockCall block + [] -> case reverse (mapMaybe plain (lines content)) of + candidate:_ -> blockCall candidate + [] -> Nothing + where + fromObject object arguments = Just (ToolCall (asString (field "name" object)) arguments + [(key, asString (field key object)) | key <- ["operation", "resource", "risk", "reason", "idempotency_key"]]) + blockCall (name, body) = do + arguments <- parseInput body + pure (ToolCall name arguments []) + plain line = + let (name, body) = break isSpace (trim line) + in if validName name && '.' `elem` name && "{" `isPrefixOf` trim body && "}" `isSuffixOf` trim body then + Just (name, body) + else Nothing + +parseInput :: String -> Maybe Json +parseInput raw = case parseJson (trim raw) of + Right value@(JObject _) -> Just value + _ -> case parseJson (concatMap (\c -> if c == '\\' then "\\\\" else [c]) (trim raw)) of + Right value@(JObject _) -> Just value + _ -> Nothing + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +validName :: String -> Bool +validName (first:rest) = isAscii first && isAlpha first && all (\c -> isAscii c && (isAlphaNum c || c `elem` "_.-")) rest +validName [] = False + +splitAtText :: String -> String -> Maybe (String, String) +splitAtText needle haystack = do + index <- findIndex (isPrefixOf needle) (tails haystack) + pure (take index haystack, drop (index + length needle) haystack) + +blocks :: String -> [(String, String)] +blocks content = case break (== '<') content of + (_, []) -> [] + (_, _:rest) -> case splitAtText ">" rest of + Nothing -> [] + Just (header, body) -> case headerName header of + Nothing -> blocks body + Just name -> case splitAtText ("") body of + Nothing -> [] + Just (arguments, suffix) -> (name, arguments) : blocks suffix + +headerName :: String -> Maybe String +headerName header + | "tool_call" `isPrefixOf` header = do + remainder <- stripPrefix "tool_call" header + if null remainder || not (isSpace (firstCharacter remainder)) then Nothing else do + named <- stripPrefix "name=\"" (dropWhile isSpace remainder) + let (name, suffix) = break (== '"') named + case suffix of + '"':after | not (null name) && all isSpace after -> Just name + _ -> Nothing + | validName header && '.' `elem` header && not (".." `isInfix` header) && not ("." `isSuffixOf` header) = Just header + | otherwise = Nothing + where + firstCharacter (first:_) = first + firstCharacter [] = 'x' + isInfix needle haystack = any (isPrefixOf needle) (tails haystack) + +stripToolCallMarkup :: String -> String +stripToolCallMarkup content | length content > 262144 = content +stripToolCallMarkup content = trim (collapse (strip content)) + where + strip [] = [] + strip text@('<':rest) = case splitAtText ">" rest of + Just (header, body) + | Just _ <- headerName header -> + let closing = "" + in case splitAtText closing body of + Just (_, suffix) -> strip suffix + Nothing -> "" + Just (header, body) -> '<' : header ++ ">" ++ strip body + Nothing -> text + strip (first:rest) = first : strip rest + collapse ('\n':'\n':'\n':rest) = collapse ('\n':'\n':rest) + collapse (first:rest) = first : collapse rest + collapse [] = [] diff --git a/src/Praxo/Wire.hs b/src/Praxo/Wire.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Wire.hs @@ -0,0 +1,7 @@ +module Praxo.Wire (specVersion, sdkVersion) where + +specVersion :: String +specVersion = "0.2.0" + +sdkVersion :: String +sdkVersion = "0.3.0" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,401 @@ +module Main (main) where + +import Control.Monad (forM_, unless) +import Data.Either (isLeft) +import Data.List (isInfixOf) +import Data.Ratio ((%)) +import Data.IORef +import qualified Praxo.Agent as A +import Praxo.Json +import Praxo.JsonSchema +import Praxo.Middleware +import qualified Praxo.OpenAICompatible as O +import qualified Praxo.Anthropic as An +import qualified Praxo.Gemini as G +import qualified Praxo.Harmovela as H +import Praxo.Pattern +import Praxo.Plugin +import Praxo.Runtime +import Praxo.ToolCall +import Praxo.Wire + +main :: IO () +main = do + agentTests + runtimeTests + middlewareTests + adapterTests + providerTests + harmovelaTests + assert "contract version" (specVersion == "0.2.0" && sdkVersion == "0.3.0") + forM_ ["", "01", "1.", "+1", "NaN", "1e", "[1,]", "{\"a\":1,}", "{}{}", "\"\\q\"", "\"\\ud800\"", "\"\\udc00\"", "\"\\ud800\\u0041\"", "\"line\nbreak\"", "true garbage"] $ \raw -> + assert ("invalid JSON " ++ show raw) (isLeft (parseJson raw)) + assert "unicode escape" (parseJson "\"\\u00e9\\ud83d\\ude00\"" == Right (JString "\x00e9\x1f600")) + assert "raw Unicode" (parseJson "\"\x00e9\"" == Right (JString "\x00e9")) + assert "exact numeric equality" (equalJson (json "1.00e2") (JNumber 100)) + assert "object ordering" (equalJson (json "{\"b\":2,\"a\":1}") (json "{\"a\":1,\"b\":2}")) + assert "duplicate keys use last value" (equalJson (json "{\"a\":1,\"a\":2}") (json "{\"a\":2}")) + assert "JSON round trip" ((encodeJson (JString "quote\" slash\\ null\0 \x1f600") >>= parseJson) == Right (JString "quote\" slash\\ null\0 \x1f600")) + assert "non-decimal rational" (isLeft (encodeJson (JNumber (1 % 3)))) + assert "surrogate output rejected" (isLeft (encodeJson (JString ['\xD800']))) + assert "JSON depth bounded" (isLeft (parseJson (replicate 66 '[' ++ "0" ++ replicate 66 ']'))) + assert "numeric exponent bounded" (isLeft (parseJson "1e99999")) + assert "input size bounded" (isLeft (parseJson (replicate 1048577 ' '))) + assert "toolcall governance metadata" (case parseToolCall "{\"name\":\"echo\",\"input\":{},\"idempotency_key\":\"k\"}" of + Just call -> lookup "idempotency_key" (callMetadata call) == Just "k" + _ -> False) + assert "toolcall rejects array input" (parseToolCall "{\"name\":\"echo\",\"input\":[]}" == Nothing) + assert "toolcall plain line must be dotted" (parseToolCall "echo {}" == Nothing) + assert "toolcall empty name rejected" (parseToolCall "{\"name\":\"\",\"input\":{}}" == Nothing) + assert "toolcall input bounded" (parseToolCall (replicate 262145 '<') == Nothing) + assert "unterminated markup is preserved" (stripToolCallMarkup "abc{}{}") == Just "b.two") + assert "invalid final toolcall cannot invoke an earlier call" (parseToolCall "{}{bad}" == Nothing) + assert "typed governance metadata rejected" (parseToolCall "{\"name\":\"echo\",\"input\":{},\"risk\":42}" == Nothing) + assert "invalid markup is not stripped" (stripToolCallMarkup "before{}after" == "before{}after") + assert "markup text preserved" (stripToolCallMarkup "before{}after" == "beforeafter") + assert "integer rejects fraction" (not (null (validation "{\"type\":\"integer\"}" "1.5"))) + assert "array item path" (map errorPath (validation "{\"type\":\"array\",\"items\":{\"type\":\"string\"}}" "[1]") == ["$[0]"]) + assert "numeric minimum" (not (null (validation "{\"type\":\"number\",\"minimum\":2}" "1"))) + assert "zero bound compatibility" (null (validation "{\"type\":\"number\",\"minimum\":0}" "-1")) + assert "enum numeric equality" (null (validation "{\"enum\":[1]}" "1.0")) + assert "optional missing property" (null (validation "{\"properties\":{\"a\":{\"type\":\"string\"}}}" "{}")) + assert "pattern range" (matchPattern "^[a-z]+[0-9]?$" "abc2" == Right True) + assert "pattern substring" (matchPattern "ab" "xxabyy" == Right True) + assert "pattern start anchor" (matchPattern "^ab" "xxab" == Right False) + assert "pattern negated class" (matchPattern "^[^0-9]+$" "abc" == Right True) + assert "pattern escaped digit" (matchPattern "^\\d+$" "123" == Right True) + assert "pattern rejects unsupported groups" (isLeft (matchPattern "(a|b)" "a")) + assert "pattern bounded work" (isLeft (matchPattern "a*" (replicate 10000 'a'))) + assert "schema surfaces unsupported pattern" (isLeft (validateSchema (json "{\"pattern\":\"(a)\"}") (JString "a"))) + assert "schema rejects non-object" (isLeft (validateSchema JNull JNull)) + forM_ ["{\"type\":42}", "{\"required\":true}", "{\"properties\":[]}", "{\"items\":false}", "{\"minimum\":\"x\"}", "{\"minLength\":-1}", "{\"properties\":{\"absent\":{\"type\":42}}}"] $ \definition -> + assert "schema rejects malformed declarations" (isLeft (validateSchema (json definition) JNull)) + let base = json "{\"schemaVersion\":1,\"id\":\"com.example.echo\",\"version\":\"1.0.0\",\"kind\":\"tool.provider.v1\",\"entrypoint\":{\"type\":\"process\",\"command\":\"echo\"},\"protocol\":\"jsonrpc-2\",\"capabilities\":[],\"permissions\":{},\"limits\":{},\"health\":{},\"isolation\":\"process\"}" + assert "valid process manifest" (validateManifest base == Right ()) + assert "duplicate manifest fields rejected" (isLeft (validateManifest (JObject (("id", JString "com.example.echo") : asObject base)))) + forM_ [("extra", JBool True), ("id", JString "Bad.ID"), ("version", JString "01.0.0"), ("protocol", JString "v1"), + ("capabilities", JArray [JString "x", JString "x"]), ("capabilities", JArray [JString ""]), + ("limits", JObject [("memoryMB", JNumber (-1))]), ("limits", JObject [("unknown", JNumber 1)]), + ("entrypoint", JObject [("type", JString "process")]), ("isolation", JString "wasm"), + ("health", JObject [("intervalMs", JNumber 10)]), ("sbom", JString "../secret"), + ("signature", JObject [("algorithm", JString "ed25519")]), + ("permissions", JObject [("network", JArray [JObject [("host", JString "example.com"), ("port", JNumber 65536)]])])] $ \(key, value) -> + assert ("invalid manifest " ++ key) (isLeft (validateManifest (set key value base))) + assert "manifest trailing data" (isLeft (parseManifest "{} {}")) + putStrLn "Haskell Core regression tests passed" + +agentTests :: IO () +agentTests = do + events <- newIORef [] + requests <- newIORef [] + calls <- newIORef (0 :: Int) + let call = A.ToolCall "id" "echo" (JObject [("x", JNumber 1)]) + sink name = modifyIORef' events (++ [name]) >> pure (Right ()) + model messages = do + modifyIORef' requests (++ [messages]) + n <- readIORef calls + pure (Right (if n == 0 then A.Response "" [call] 2 1 else A.Response "done" [] 1 1)) + tool _ = modifyIORef' calls (+1) >> pure (Right JNull) + options = A.AgentOptions model tool sink 2 5 + result <- A.runAgent options [] "hello" + assert "agent success and usage" (case result of Right r -> A.runSteps r == 2 && A.runInputTokens r == 3 && A.runOutputTokens r == 2; _ -> False) + history <- readIORef requests + assert "agent tool history" (case history of [_, [user, assistant, toolMessage]] -> A.messageRole user == "user" && A.messageToolCalls assistant == [call] && A.messageToolCallId toolMessage == "id" && A.messageContent toolMessage == "null"; _ -> False) + recorded <- readIORef events + assert "agent event order" (recorded == ["run.started", "tool.call", "run.completed"]) + let failure = A.AgentError "CUSTOM" "failure" + checkFailure label opts expectedEvents = do + writeIORef events [] + actual <- A.runAgent opts [] "x" + recordedEvents <- readIORef events + assert label (actual == Left failure && recordedEvents == expectedEvents) + checkFailure "model error" (options { A.generate = \_ -> pure (Left failure) }) ["run.started", "run.failed"] + checkFailure "tool error" (options { A.generate = \_ -> pure (Right (A.Response "" [call] 0 0)), A.invoke = \_ -> pure (Left failure) }) ["run.started", "tool.call", "run.failed"] + let badSink name = sink name >> pure (if name == "tool.call" then Left failure else Right ()) + checkFailure "event error" (options { A.generate = \_ -> pure (Right (A.Response "" [call] 0 0)), A.emit = badSink }) ["run.started", "tool.call", "run.failed"] + writeIORef events [] + started <- A.runAgent (options { A.emit = \name -> sink name >> pure (Left failure) }) [] "x" + startedEvents <- readIORef events + assert "started event error" (started == Left failure && startedEvents == ["run.started"]) + let completedSink name = sink name >> pure (if name == "run.completed" || name == "run.failed" then Left failure else Right ()) + checkFailure "completion event error" (options { A.generate = \_ -> pure (Right (A.Response "done" [] 0 0)), A.emit = completedSink }) ["run.started", "run.completed", "run.failed"] + let failedSink name = sink name >> pure (if name == "run.failed" then Left (A.AgentError "SINK" "sink failure") else Right ()) + checkFailure "failure event preserves original error" (options { A.generate = \_ -> pure (Left failure), A.emit = failedSink }) ["run.started", "run.failed"] + writeIORef events [] + budget <- A.runAgent (options { A.generate = \_ -> pure (Right (A.Response "x" [] 3 3)) }) [] "x" + assert "input and output token budget" (case budget of Left err -> A.errorCode err == "AGENT_MAX_TOKENS"; _ -> False) + let invalidUsage = Left (A.AgentError "AGENT_INVALID_USAGE" "agent: token usage must be non-negative") + forM_ [("negative input", -1, 2), ("negative output", 2, -1)] $ \(label, input, output) -> do + writeIORef events [] + writeIORef calls 0 + invalid <- A.runAgent (options { A.maxTokens = 0, A.generate = \_ -> pure (Right (A.Response "" [call] input output)) }) [] "x" + invalidEvents <- readIORef events + invalidCalls <- readIORef calls + assert label (invalid == invalidUsage && invalidEvents == ["run.started", "run.failed"] && invalidCalls == 0) + writeIORef events [] + writeIORef calls 0 + offset <- A.runAgent (options { A.generate = \_ -> do + n <- readIORef calls + pure (Right (if n == 0 then A.Response "" [call] 4 1 else A.Response "" [call] (-5) 2)) }) [] "x" + offsetEvents <- readIORef events + offsetCalls <- readIORef calls + assert "negative usage cannot offset prior steps" (offset == invalidUsage && offsetEvents == ["run.started", "tool.call", "run.failed"] && offsetCalls == 1) + encoding <- A.runAgent (options { A.generate = \_ -> pure (Right (A.Response "" [call] 0 0)), A.invoke = \_ -> pure (Right (JNumber (1 % 3))) }) [] "x" + assert "tool result encoding error" (case encoding of Left err -> A.errorCode err == "TOOL_RESULT"; _ -> False) + writeIORef calls 0 + limited <- A.runAgent (options { A.maxSteps = 0, A.generate = \_ -> pure (Right (A.Response "" [call] 0 0)) }) [] "x" + count <- readIORef calls + assert "default step budget" (count == 8 && case limited of Left err -> A.errorCode err == "AGENT_MAX_STEPS"; _ -> False) + +runtimeTests :: IO () +runtimeTests = do + let (store1, _) = memoryPut newMemoryStore "s1" (MemoryRecord "m1" "event" "Alpha" "2026-01-01") + (store2, _) = memoryPut store1 "s1" (MemoryRecord "m2" "event" "beta" "2026-01-02") + (store3, _) = memoryPut store2 "s1" (MemoryRecord "m3" "decision" "ALPHABET" "2026-01-03") + assert "memory ordering" (map recordId (memorySearch store3 "s1" "alpha" 10) == ["m3", "m1"]) + assert "memory limit" (map recordId (memorySearch store3 "s1" "alpha" 1) == ["m3"]) + assert "memory isolation" (null (memorySearch store3 "s2" "alpha" 10)) + let events = [Event "a" "s1" Nothing JNull, Event "b" "s1" Nothing JNull] + filtered = foldl emitSink (filterSink newSink ["b"]) events + multi = foldl emitSink (multiSink [newSink, newSink]) events + assert "event filter" (sinkKinds filtered == ["b"]) + assert "event multi" (sinkKindLists multi == [["a", "b"], ["a", "b"]]) + assert "stream kinds" (streamKinds == ["values", "updates", "messages", "tasks", "debug", "checkpoint"]) + let allow = either error id (registerCheckpoint newCheckpoint "spec.payload") + case checkpointMarshal allow "spec.payload" (json "{\"value\":\"x\"}") of + Left detail -> fail detail + Right data' -> case checkpointUnmarshal allow data' of + Left detail -> fail detail + Right decoded -> assert "checkpoint roundtrip" (equalJson decoded (json "{\"value\":\"x\"}")) + assert "checkpoint allowlist" (checkpointMarshal allow "missing" JNull == Left "CHECKPOINT_TYPE_NOT_ALLOWED") + let checker = either error id (pathChecker [PathGrant "allowed" "read"]) + assert "policy traversal" (not (pathAllowed checker "../allowed/secret" "read")) + assert "policy inside" (pathAllowed checker "allowed/sub/../secret" "read") + assert "policy parent segments" (normalizePath "../../a/../b" == "../../b") + let messages = [ContextMessage "system" "sys" [] [] Nothing, ContextMessage "user" "message 0" [] [] Nothing, ContextMessage "user" "message 1" [] [] Nothing] + assert "context estimate" (estimateTokens messages == 16) + assert "context disabled" (let (output, ok) = compactContext (ContextBudget 0 0) messages in ok && length output == 3) + +middlewareTests :: IO () +middlewareTests = do + assert "pii email" (piiRedact "email a@b.com" == "email [REDACTED:email]") + assert "pii ssn" (piiRedact "ssn 123-45-6789" == "ssn [REDACTED:ssn]") + assert "pii card" (piiRedact "card 4111 1111 1111 1111" == "card [REDACTED:credit_card]") + assert "pii phone" (piiRedact "call 415-555-2671" == "call [REDACTED:phone]") + assert "pii boundary" (piiRedact "version 1.2.3" == "version 1.2.3") + let schema = json "{\"type\":\"object\",\"required\":[\"name\"],\"properties\":{\"name\":{\"type\":\"string\"}}}" + repaired = structuredOutput schema 1 (Just (\_ -> Right "{\"name\":\"fixed\"}")) + failing = structuredOutput schema 0 Nothing + assert "structured repair" (applyStructured repaired "bad" == Right "{\"name\":\"fixed\"}") + assert "structured failure" (applyStructured failing "bad" == Left "AGENT_STRUCTURED_OUTPUT") + assert "tool limit" (case callLimitTool (callLimit 0 1) >>= callLimitTool of Left code -> code == "AGENT_TOOL_CALL_LIMIT"; _ -> False) + assert "model limit" (case callLimitModel (callLimit 1 0) >>= callLimitModel of Left code -> code == "AGENT_MODEL_CALL_LIMIT"; _ -> False) + assert "tool selection" (selectTools (toolSelection ["echo"]) ["echo", "other"] == ["echo"]) + assert "tool selection reject" (checkToolSelected (toolSelection []) "echo" == Left "AGENT_TOOL_NOT_SELECTED") + assert "fallback" (fallbackEither (Left "MODEL_ERROR" :: Either String String) (Right "ok") == Right "ok") + +adapterTests :: IO () +adapterTests = do + captured <- newIORef Nothing + let responseBody = "{\"choices\":[{\"message\":{\"content\":\"done\",\"tool_calls\":[{\"id\":\"call-1\",\"type\":\"function\",\"function\":{\"name\":\"echo\",\"arguments\":\"{\\\"text\\\":\\\"hi\\\"}\"}}]},\"finish_reason\":\"tool_calls\"}],\"usage\":{\"prompt_tokens\":3,\"completion_tokens\":2}}" + transport request = do + writeIORef captured (Just request) + pure (Right (O.HttpResponse 200 responseBody)) + config = O.OpenAIConfig + { O.openAIBaseURL = "https://api.example.com/v1/" + , O.openAIModel = "test-model" + , O.openAIKey = Just "secret" + , O.openAIToolChoice = Just "auto" + , O.openAITools = [O.OpenAITool "echo" "Echo" (JObject [("type", JString "object")])] + , O.openAITransport = O.Transport transport + } + messages = [A.Message "user" "hi" [] "", A.Message "tool" "{}" [] "call-1"] + result <- O.generate config messages + case result of + Left err -> fail ("openai adapter: " ++ A.errorMessage err) + Right response -> do + assert "openai content" (A.responseContent response == "done") + assert "openai usage" (A.inputTokens response == 3 && A.outputTokens response == 2) + case A.responseToolCalls response of + [call] -> do + assert "openai call id" (A.toolCallId call == "call-1") + assert "openai call name" (A.toolCallName call == "echo") + assert "openai call arguments" (A.toolCallArguments call == JObject [("text", JString "hi")]) + _ -> fail "openai call" + request <- readIORef captured + case request of + Nothing -> fail "openai transport not called" + Just http -> do + assert "openai method" (O.httpMethod http == "POST") + assert "openai url" (O.httpURL http == "https://api.example.com/v1/chat/completions") + assert "openai auth" (lookup "Authorization" (O.httpHeaders http) == Just "Bearer secret") + let payload = json (O.httpBody http) + assert "openai model" (equalJson (field "model" payload) (JString "test-model")) + assert "openai tool choice" (equalJson (field "tool_choice" payload) (JString "auto")) + let payloadMessages = asArray (field "messages" payload) + assert "openai messages" (length payloadMessages == 2 && equalJson (field "tool_call_id" (payloadMessages !! 1)) (JString "call-1")) + let payloadTools = asArray (field "tools" payload) + assert "openai tools" (length payloadTools == 1 && equalJson (field "name" (field "function" (head payloadTools))) (JString "echo")) + let failing = O.Transport (\_ -> pure (Right (O.HttpResponse 503 "down"))) + failed <- O.generate (config { O.openAITransport = failing }) messages + assert "openai provider error" (case failed of Left err -> A.errorCode err == "PROVIDER_HTTP"; _ -> False) + let missing = config + { O.openAIBaseURL = "" + , O.openAITransport = O.Transport (\_ -> fail "transport called for missing base URL") + } + missingResult <- O.generate missing messages + assert "openai missing base url" (case missingResult of Left err -> A.errorCode err == "PROVIDER_HTTP"; _ -> False) + let invalid = O.Transport (\_ -> pure (Right (O.HttpResponse 200 "{\"choices\":[{\"message\":{\"tool_calls\":[{\"id\":\"c\",\"function\":{\"name\":\"x\",\"arguments\":\"{bad\"}}]}}]}"))) + invalidResult <- O.generate (config { O.openAITransport = invalid }) [A.Message "user" "hi" [] ""] + assert "openai invalid arguments" (case invalidResult of Left err -> A.errorCode err == "PROVIDER_RESPONSE"; _ -> False) + +providerTests :: IO () +providerTests = do + capturedAnthropic <- newIORef Nothing + let anthropicTransport = O.Transport (\request -> do + writeIORef capturedAnthropic (Just request) + pure (Right (O.HttpResponse 200 "{\"content\":[{\"type\":\"text\",\"text\":\"hello\"},{\"type\":\"tool_use\",\"id\":\"tool-1\",\"name\":\"echo\",\"input\":{\"text\":\"hi\"}}],\"stop_reason\":\"end_turn\",\"usage\":{\"input_tokens\":3,\"output_tokens\":4,\"cache_read_input_tokens\":2}}"))) + anthropicConfig = An.AnthropicConfig + { An.anthropicBaseURL = "https://api.anthropic.com" + , An.anthropicModel = "claude-test" + , An.anthropicKey = Just "ak" + , An.anthropicVersion = "2023-06-01" + , An.anthropicMaxTokens = 1024 + , An.anthropicToolChoice = Just "auto" + , An.anthropicTools = [An.AnthropicTool "echo" "Echo" (JObject [("type", JString "object")])] + , An.anthropicTransport = anthropicTransport + } + messages = [A.Message "system" "be brief" [] "", A.Message "user" "hi" [] ""] + anthropicResult <- An.generateAnthropic anthropicConfig messages + case anthropicResult of + Left err -> fail ("anthropic adapter: " ++ A.errorMessage err) + Right response -> do + assert "anthropic content" (A.responseContent response == "hello") + assert "anthropic usage" (A.inputTokens response == 3 && A.outputTokens response == 4) + case A.responseToolCalls response of + [call] -> do + assert "anthropic call id" (A.toolCallId call == "tool-1") + assert "anthropic call name" (A.toolCallName call == "echo") + assert "anthropic arguments" (A.toolCallArguments call == JObject [("text", JString "hi")]) + _ -> fail "anthropic call" + request <- readIORef capturedAnthropic + case request of + Nothing -> fail "anthropic transport not called" + Just http -> do + assert "anthropic url" (O.httpURL http == "https://api.anthropic.com/v1/messages") + assert "anthropic key" (lookup "x-api-key" (O.httpHeaders http) == Just "ak") + let payload = json (O.httpBody http) + assert "anthropic model" (field "model" payload == JString "claude-test") + assert "anthropic system" (field "system" payload == JString "be brief") + assert "anthropic tools" (length (asArray (field "tools" payload)) == 1) + + capturedGemini <- newIORef Nothing + let geminiTransport = O.Transport (\request -> do + writeIORef capturedGemini (Just request) + pure (Right (O.HttpResponse 200 "{\"candidates\":[{\"content\":{\"parts\":[{\"text\":\"hello\"},{\"functionCall\":{\"name\":\"echo\",\"args\":{\"text\":\"hi\"}}}]},\"finishReason\":\"STOP\"}],\"usageMetadata\":{\"promptTokenCount\":3,\"candidatesTokenCount\":4}}"))) + geminiConfig = G.GeminiConfig + { G.geminiBaseURL = "https://generativelanguage.googleapis.com" + , G.geminiModel = "gemini-test" + , G.geminiKey = Just "gk" + , G.geminiMaxOutputTokens = 0 + , G.geminiToolChoice = Just "auto" + , G.geminiTools = [G.GeminiTool "echo" "Echo" (JObject [("type", JString "object")])] + , G.geminiTransport = geminiTransport + } + geminiResult <- G.generateGemini geminiConfig messages + case geminiResult of + Left err -> fail ("gemini adapter: " ++ A.errorMessage err) + Right response -> do + assert "gemini content" (A.responseContent response == "hello") + assert "gemini usage" (A.inputTokens response == 3 && A.outputTokens response == 4) + case A.responseToolCalls response of + [call] -> assert "gemini call name" (A.toolCallName call == "echo") + _ -> fail "gemini call" + geminiRequest <- readIORef capturedGemini + case geminiRequest of + Nothing -> fail "gemini transport not called" + Just http -> do + assert "gemini url" (":generateContent" `isInfixOf` O.httpURL http) + assert "gemini key" (lookup "x-goog-api-key" (O.httpHeaders http) == Just "gk") + let payload = json (O.httpBody http) + assert "gemini system" (length (asArray (field "parts" (field "system_instruction" payload))) == 1) + assert "gemini tools" (length (asArray (field "functionDeclarations" (head (asArray (field "tools" payload))))) == 1) + +harmovelaTests :: IO () +harmovelaTests = do + captured <- newIORef ([] :: [H.HarmovelaRequest]) + let transport = H.HarmovelaTransport (\request -> do + modifyIORef' captured (++ [request]) + pure (Right (H.HarmovelaResponse 201 ""))) + sink = H.newHarmovelaSink "http://harmovela.test/aep/api/" transport (pure 1794294000000000000) + event = Event "tool.call" "s1" (Just "run-123") (JObject [("name", JString "echo")]) + result <- H.emitHarmovelaEvent sink event + assert "harmovela success" (result == Right ()) + requests <- readIORef captured + case requests of + [request] -> do + assert "harmovela method" (H.harmovelaMethod request == "POST") + assert "harmovela path" (H.harmovelaURL request == "http://harmovela.test/aep/api/events") + assert "harmovela content type" (lookup "content-type" (H.harmovelaHeaders request) == Just "application/json") + let envelope = json (H.harmovelaBody request) + assert "harmovela spec" (field "spec_version" envelope == JString "0.2") + assert "harmovela id" (field "id" envelope == JString "run-123-1794294000000000000") + assert "harmovela type" (field "type" envelope == JString "tool.call") + assert "harmovela source" (field "source" envelope == JString "praxo-core") + assert "harmovela created at" (field "created_at" envelope == JString "2026-11-10T07:00:00.000000000Z") + assert "harmovela payload" (equalJson (field "payload" envelope) + (json "{\"name\":\"echo\",\"session_id\":\"s1\",\"run_id\":\"run-123\"}")) + _ -> fail "harmovela request count" + customCaptured <- newIORef ([] :: [H.HarmovelaRequest]) + let customTransport = H.HarmovelaTransport (\request -> do + modifyIORef' customCaptured (++ [request]) + pure (Right (H.HarmovelaResponse 204 ""))) + custom = (H.newHarmovelaSink "http://harmovela.test" customTransport (pure 1794294000000000000)) + { H.harmovelaSource = "custom", H.harmovelaSpecVersion = "0.3" } + mergedEvent = Event "tool.call" "s1" Nothing + (JObject [("name", JString "echo"), ("session_id", JString "event-side"), ("run_id", JString "old")]) + customResult <- H.emitHarmovelaEvent custom mergedEvent + assert "harmovela custom success" (customResult == Right ()) + customRequests <- readIORef customCaptured + case customRequests of + [request] -> do + let envelope = json (H.harmovelaBody request) + assert "harmovela custom source" (field "source" envelope == JString "custom") + assert "harmovela custom spec" (field "spec_version" envelope == JString "0.3") + assert "harmovela session id prefix" (take 3 (asString (field "id" envelope)) == "s1-") + assert "harmovela merged payload" (equalJson (field "payload" envelope) + (json "{\"name\":\"echo\",\"session_id\":\"s1\",\"run_id\":\"old\"}")) + _ -> fail "harmovela custom request count" + forM_ [200, 201, 204, 299] $ \status -> do + let accepted = H.newHarmovelaSink "http://harmovela.test" + (H.HarmovelaTransport (\_ -> pure (Right (H.HarmovelaResponse status "")))) + (pure 1) + acceptedResult <- H.emitHarmovelaEvent accepted event + assert ("harmovela accepted status " ++ show status) (acceptedResult == Right ()) + let failing = H.newHarmovelaSink "http://harmovela.test" + (H.HarmovelaTransport (\_ -> pure (Right (H.HarmovelaResponse 503 (concat (replicate 100 "service down ")))))) + (pure 1) + failed <- H.emitHarmovelaEvent failing event + case failed of + Left err -> do + assert "harmovela error code" (A.errorCode err == "HARMOVELA_HTTP") + assert "harmovela error status" ("503" `isInfixOf` A.errorMessage err) + assert "harmovela error body" ("service down" `isInfixOf` A.errorMessage err) + assert "harmovela error bounded" (length (A.errorMessage err) <= 600) + Right () -> fail "harmovela expected non-2xx error" + let missing = H.newHarmovelaSink "" (H.HarmovelaTransport (\_ -> fail "harmovela transport called for missing base URL")) (pure 1) + missingResult <- H.emitHarmovelaEvent missing event + assert "harmovela missing base url" (case missingResult of Left err -> A.errorCode err == "HARMOVELA_URL"; _ -> False) + +assert :: String -> Bool -> IO () +assert label condition = unless condition (fail label) + +json :: String -> Json +json = either error id . parseJson + +validation :: String -> String -> [ValidationError] +validation schema value = either error id (validateSchema (json schema) (json value)) + +set :: String -> Json -> Json -> Json +set key value object = JObject ((key, value) : filter ((/= key) . fst) (asObject object))