praxo-core (empty) → 0.3.0
raw patch · 27 files changed
+3146/−0 lines, 27 filesdep +basedep +containersdep +praxo-coresetup-changed
Dependencies added: base, containers, praxo-core
Files
- LICENSE +21/−0
- README.md +191/−0
- REGISTRY.md +42/−0
- SETUP.md +58/−0
- Setup.hs +4/−0
- api-snapshot.py +87/−0
- api/0.1.0.txt +125/−0
- api/0.2.0.txt +41/−0
- conformance/Main.hs +228/−0
- llms.md +35/−0
- llms.txt +35/−0
- praxo-core.cabal +43/−0
- run-tests.py +33/−0
- src/Praxo/Agent.hs +64/−0
- src/Praxo/Anthropic.hs +171/−0
- src/Praxo/Gemini.hs +162/−0
- src/Praxo/Harmovela.hs +159/−0
- src/Praxo/Json.hs +149/−0
- src/Praxo/JsonSchema.hs +92/−0
- src/Praxo/Middleware.hs +217/−0
- src/Praxo/OpenAICompatible.hs +171/−0
- src/Praxo/Pattern.hs +79/−0
- src/Praxo/Plugin.hs +159/−0
- src/Praxo/Runtime.hs +265/−0
- src/Praxo/ToolCall.hs +107/−0
- src/Praxo/Wire.hs +7/−0
- tests/Main.hs +401/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ REGISTRY.md view
@@ -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.
+ SETUP.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple (defaultMain)++main :: IO ()+main = defaultMain
+ api-snapshot.py view
@@ -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())
+ api/0.1.0.txt view
@@ -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
+ api/0.2.0.txt view
@@ -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
+ conformance/Main.hs view
@@ -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 <spec-directory>"+ 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
+ llms.md view
@@ -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.
+ llms.txt view
@@ -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.
+ praxo-core.cabal view
@@ -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 <releases@axisvela.com>+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
+ run-tests.py view
@@ -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()
+ src/Praxo/Agent.hs view
@@ -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
+ src/Praxo/Anthropic.hs view
@@ -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
+ src/Praxo/Gemini.hs view
@@ -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
+ src/Praxo/Harmovela.hs view
@@ -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
+ src/Praxo/Json.hs view
@@ -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)
+ src/Praxo/JsonSchema.hs view
@@ -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
+ src/Praxo/Middleware.hs view
@@ -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
+ src/Praxo/OpenAICompatible.hs view
@@ -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
+ src/Praxo/Pattern.hs view
@@ -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"
+ src/Praxo/Plugin.hs view
@@ -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)
+ src/Praxo/Runtime.hs view
@@ -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)
+ src/Praxo/ToolCall.hs view
@@ -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 ("</" ++ takeWhile (not . isSpace) header ++ ">") 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 = "</" ++ takeWhile (not . isSpace) header ++ ">"+ 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 [] = []
+ src/Praxo/Wire.hs view
@@ -0,0 +1,7 @@+module Praxo.Wire (specVersion, sdkVersion) where++specVersion :: String+specVersion = "0.2.0"++sdkVersion :: String+sdkVersion = "0.3.0"
+ tests/Main.hs view
@@ -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<not a block" == "abc<not a block")+ assert "toolcall last block wins" (fmap callName (parseToolCall "<a.one>{}</a.one><b.two>{}</b.two>") == Just "b.two")+ assert "invalid final toolcall cannot invoke an earlier call" (parseToolCall "<a.one>{}</a.one><b.two>{bad}</b.two>" == Nothing)+ assert "typed governance metadata rejected" (parseToolCall "{\"name\":\"echo\",\"input\":{},\"risk\":42}" == Nothing)+ assert "invalid markup is not stripped" (stripToolCallMarkup "before<tool_call bogus>{}</tool_call>after" == "before<tool_call bogus>{}</tool_call>after")+ assert "markup text preserved" (stripToolCallMarkup "before<a.one>{}</a.one>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))