commit d5088b114ec5e2bbd0b5bfa7ff28332ccf16b5ab
parent 6f4e307062641c8267670495ab2db38fe9f590bb
Author: James Eversole <james@eversole.co>
Date: Tue, 5 May 2026 19:16:16 -0500
Wire format, JS runtime, and Arborix bundle export server
Diffstat:
29 files changed, 3369 insertions(+), 67 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -6,6 +6,7 @@
/Dockerfile
/config.dhall
/result
+/result*
.aider*
WD
bin/
diff --git a/AGENTS.md b/AGENTS.md
@@ -1,38 +1,22 @@
-# AGENTS.md — tricu Project Guide
+# AGENTS.md - tricu Project Guide
> For AI agents and contributors working in this repository.
## 1. Build & Test
-**`nix build .#` always runs tests.** This is the primary and only way to build and validate.
-
```bash
-# Full build + tests (this is the default)
+# Full build + tests
nix build .#
-
-# Build only (skip tests)
-nix build .#package
-
-# Build the test-specific variant with doCheck enforced
-nix build .#test
-nix flake check
-
-# Dev shell (includes ghcid, cabal-install, ghc, upx)
-nix develop .#
```
### ⚠️ Never call `cabal` directly
-This project uses a Nix flake that wraps `callCabal2nix` to produce the cabal package. All compilation, linking, and test execution are driven through Nix. Running `cabal build`, `cabal test`, `cabal repl`, or `cabal install` directly will use the system GHC (or `.stack-work`) and can produce artifacts that differ from the Nix-built ones — especially regarding `megaparsec` which is a project dependency.
-
> **Rule of thumb:** if it builds, links, or tests, it goes through `nix`.
## 2. Project Overview
**tricu** (pronounced "tree-shoe") is a programming-language experiment written in Haskell. It implements [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extension of Barry Jay's Tree Calculus, with lambda-abstraction sugar that gets eliminated back to pure tree calculus terms.
-tricu is Lojban for "tree".
-
### Core types (in `src/Research.hs`)
| Type | Description |
@@ -45,7 +29,7 @@ tricu is Lojban for "tree".
### Source modules
| Module | Purpose |
-|--------|---------|
+|--------|---------|
| `Main.hs` | CLI entry point (`cmdargs`), three modes: `repl`, `eval`, `decode` |
| `Eval.hs` | Interpreter: `evalTricu`, `result`, `evalSingle` |
| `Parser.hs` | Megaparsec parser → `TricuAST` |
@@ -54,11 +38,12 @@ tricu is Lojban for "tree".
| `REPL.hs` | Interactive Read-Eval-Print Loop (haskeline) |
| `Research.hs` | Core types, `apply` reduction, booleans, marshalling (`ofString`, `ofNumber`), output formatters (`toAscii`, `toTernaryString`, `decodeResult`) |
| `ContentStore.hs` | SQLite-backed term persistence |
+| `Wire.hs` | Arborix portable wire format — encode/decode/import/export of Merkle-DAG bundle blobs |
### File extensions
-- `.hs` — Haskell source
-- `.tri` — tricu language source (used in `lib/`, `test/`, `demos/`)
+- `.hs` - Haskell source
+- `.tri` - tricu language source (used in `lib/`, `test/`, `demos/`)
## 3. Test Suite
@@ -72,25 +57,23 @@ nix flake check # or: nix build .#test
| Group | What it covers |
|-------|----------------|
-| `lexer` | Megaparsec lexer — identifiers, keywords, strings, escapes, invalid tokens |
-| `parser` | Parser — defs, lambda, applications, lists, comments, parentheses |
+| `lexer` | Megaparsec lexer - identifiers, keywords, strings, escapes, invalid tokens |
+| `parser` | Parser - defs, lambda, applications, lists, comments, parentheses |
| `simpleEvaluation` | Core `apply` reduction rules, variable substitution, immutability |
| `lambdas` | Lambda elimination, SKI calculus, higher-order functions, currying, shadowing, free vars |
-| `providedLibraries` | `lib/list.tri` — triage, booleans, list ops (`head`, `tail`, `map`, `emptyList?`, `append`, `equal?`) |
+| `providedLibraries` | `lib/list.tri` - triage, booleans, list ops (`head`, `tail`, `map`, `emptyList?`, `append`, `equal?`) |
| `fileEval` | Loading `.tri` files, multi-file context, decode |
| `modules` | `!import`, cyclic deps, namespacing, multi-level imports, unresolved vars, local namespaces |
-| `demos` | `demos/*.tri` — structural equality, `toSource`, `size`, level-order traversal |
-| `decoding` | `decodeResult` — Leaf, numbers, strings, lists, mixed |
+| `demos` | `demos/*.tri` - structural equality, `toSource`, `size`, level-order traversal |
+| `decoding` | `decodeResult` - Leaf, numbers, strings, lists, mixed |
| `elimLambdaSingle` | Lambda elimination: eta reduction, SDef binding, semantics preservation |
| `stressElimLambda` | Lambda elimination stress test: 200 vars, 800-body curried lambda |
-### Adding tests
+### Suggesting tests
-1. Append a `testCase "Description" $ do ...` block to the appropriate test group in `test/Spec.hs`.
-2. Import any modules you need (lexer/parser are available via `runParser` from `Text.Megapparsec`; evaluation via `evalTricu`, `parseTricu`, `result`).
-3. Run `nix flake check` to verify.
+You do not write or modify tests. The user writes tests to constrain your outputs. You must adhere your code to tests or suggest modifications to tests.
-> The test-suite in `tricu.cabal` pulls in `src/` as `hs-source-dirs`, so tests import modules directly (e.g., `import Eval`, `import Lexer`). This is intentional — tests exercise the full pipeline end-to-end.
+If the user gives you explicit permission to implement a test you may proceed.
## 4. tricu Language Quick Reference
@@ -106,7 +89,6 @@ head (map f xs) → From lib/list.tri
!import "./path.tri" NS → Import file under namespace
-- line comment
-|- block comment -|
```
## 5. Output Formats
@@ -131,12 +113,121 @@ NLeaf → 0x00
NStem(h) → 0x01 || h (32 bytes)
NFork(l,r) → 0x02 || l (32 bytes) || r (32 bytes)
-hash = SHA256("tricu.merkle.node.v1" <> 0x00 <> serialized_node)
+hash = SHA256("arborix.merkle.node.v1" <> 0x00 <> serialized_node)
```
This is stored in SQLite via `ContentStore.hs`. Hash suffixes on identifiers (e.g., `foo_abc123...`) are validated: 16–64 hex characters (SHA256).
-## 7. Directory Layout
+## 7. Arborix Portable Wire Format
+
+The **Arborix wire format** (module `Wire.hs`) defines a portable binary bundle for exchanging Tree Calculus terms, their Merkle DAGs, and associated metadata. It is versioned and schema-driven.
+
+### Header
+
+```
++------------------+-----------------+------------------+----------------+
+| Magic (8 bytes) | Major (2 bytes) | Minor (2 bytes) | Section Count |
+| | | | (4 bytes) |
++------------------+-----------------+------------------+----------------+
+| Flags (8 bytes) | Dir Offset (8 bytes)
++------------------+-----------------+------------------+
+```
+
+- **Magic**: `ARBORIX\0` (`0x41 0x52 0x42 0x4f 0x52 0x49 0x58 0x00`)
+- **Header length**: 32 bytes
+- **Major version**: `1` | **Minor version**: `0`
+
+### Section Directory
+
+Immediately follows the header. Each section entry is 60 bytes:
+
+```
++------------------+------------------+-----------------+------------------+
+| Type (4 bytes) | Version (2 bytes)| Flags (2 bytes) | Compression (2) |
++------------------+------------------+-----------------+------------------+
+| Digest Algo (2) | Offset (8 bytes) | Length (8 bytes)| SHA256 digest (32)|
++------------------+------------------+-----------------+------------------+
+```
+
+Known section types:
+
+| Type | Name | Required | Description |
+|------|-----------|----------|-------------|
+| 1 | manifest | Yes | JSON manifest metadata |
+| 2 | nodes | Yes | Binary Merkle node payloads |
+
+### Section 1 — Manifest (JSON)
+
+The manifest describes the bundle's semantics, exports, and schema. Key fields:
+
+| Field | Value | Description |
+|-------|-------|-------------|
+| `schema` | `"arborix.bundle.manifest.v1"` | Manifest schema version |
+| `bundleType` | `"tree-calculus-executable-object"` | Bundle category |
+| `tree.calculus` | `"tree-calculus.v1"` | Tree calculus version |
+| `tree.nodeHash.algorithm` | `"sha256"` | Hash algorithm |
+| `tree.nodeHash.domain` | `"arborix.merkle.node.v1"` | Hash domain string |
+| `tree.nodePayload` | `"arborix.merkle.payload.v1"` | Payload encoding |
+| `runtime.semantics` | `"tree-calculus.v1"` | Evaluation semantics |
+| `runtime.abi` | `"arborix.abi.tree.v1"` | Runtime ABI |
+| `closure` | `"complete"` | Bundle must be a complete DAG |
+| `roots` | `[{"hash": "...", "role": "..."}]` | Named root hashes |
+| `exports` | `[{"name": "...", "root": "..."}]` | Export aliases for roots |
+| `metadata.createdBy` | `"arborix"` | Originator |
+
+### Section 2 — Nodes (Binary)
+
+```
++------------------+-------------------+-------------------+-----------------+
+| Node Count (8) | Hash (32 bytes) | Payload Len (4) | Payload (N) |
++------------------+-------------------+-------------------+-----------------+
+```
+
+Each node entry contains:
+- 32-byte Merkle hash (hex-encoded in identifiers, raw in binary)
+- 4-byte big-endian payload length
+- N bytes of serialized node payload (`0x00` for Leaf, `0x01 || hash` for Stem, `0x02 || left || right` for Fork)
+
+### Bundle verification flow
+
+1. Check magic bytes
+2. Validate major version
+3. Parse section directory
+4. For each section: verify SHA256 digest against actual bytes
+5. Decode JSON manifest
+6. Decode binary node entries into Merkle DAG
+7. Verify all root hashes present in manifest exist in node map
+8. Verify export root hashes present
+9. Verify children references are complete (no dangling nodes)
+10. Reject unknown critical sections
+
+### Data types (Wire.hs)
+
+| Type | Purpose |
+|------|---------|
+| `Bundle` | Top-level bundle: version, roots, nodes map, manifest |
+| `BundleManifest` | JSON metadata: schema, tree spec, runtime spec, roots, exports |
+| `TreeSpec` | Tree calculus version + hash algorithm + payload encoding |
+| `NodeHashSpec` | Hash algorithm and domain string |
+| `RuntimeSpec` | Semantics, evaluation order, ABI, capabilities |
+| `BundleRoot` | Root hash + role (`"default"` or `"root"`) |
+| `BundleExport` | Export name + root hash + kind + ABI |
+| `BundleMetadata` | Optional package, version, description, license, createdBy |
+| `ClosureMode` | `ClosureComplete` or `ClosurePartial` |
+
+### Key functions
+
+| Function | Signature | Purpose |
+|----------|-----------|---------|
+| `encodeBundle` | `Bundle → ByteString` | Serialize bundle to wire bytes |
+| `decodeBundle` | `ByteString → Either String Bundle` | Parse wire bytes into Bundle |
+| `verifyBundle` | `Bundle → Either String ()` | Validate DAG, manifest, roots |
+| `collectReachableNodes` | `Connection → MerkleHash → IO [(MerkleHash, ByteString)]` | Traverse DAG from root |
+| `exportBundle` | `Connection → [MerkleHash] → IO ByteString` | Build bundle from content store |
+| `exportNamedBundle` | `Connection → [(Text, MerkleHash)] → IO ByteString` | Build with named roots |
+| `importBundle` | `Connection → ByteString → IO [MerkleHash]` | Import bundle into content store |
+
+## 8. Directory Layout
```
tricu/
@@ -150,7 +241,8 @@ tricu/
│ ├── FileEval.hs
│ ├── REPL.hs
│ ├── Research.hs
-│ └── ContentStore.hs
+│ ├── ContentStore.hs
+│ └── Wire.hs # Arborix portable wire format
├── test/
│ ├── Spec.hs # Tasty + HUnit tests
│ ├── *.tri # tricu test programs
@@ -168,10 +260,75 @@ tricu/
└── AGENTS.md # This file
```
-## 8. Development Tips
+## 9. JS Arborix Runtime
-- **Quick iteration:** `nix develop` then `ghcid` (provided in the devShell) watches files and re-runs.
-- **REPL:** `nix run .#` starts the interactive REPL.
+A JavaScript implementation of the Arborix portable bundle runtime lives in `ext/js/`.
+It is a reference implementation — not a tricu source parser. It reads `.tri.bundle` files produced by the Haskell toolchain, verifies Merkle node hashes, reconstructs tree values, and reduces them.
+
+From project root:
+```bash
+node ext/js/src/cli.js inspect test/fixtures/id.tri.bundle
+node ext/js/src/cli.js run test/fixtures/true.tri.bundle
+```
+
+The JS runtime implements:
+- Bundle binary format parsing (header, section directory, manifest, nodes)
+- SHA-256 Merkle node hash verification against canonical payloads
+- Closure verification (all child references present)
+- Tree reconstruction from node DAG
+- Core `apply` reduction rules
+- Basic codecs (decodeResult)
+- CLI: `inspect` and `run` commands
+
+## 10. Content Store Workflow (Custom DB)
+
+The content store location is controlled by the `TRICU_DB_PATH` environment variable. When set, `eval` mode automatically loads all stored terms into the initial environment, so you can call any previously imported/evaluated term by name.
+
+```bash
+# Use a local DB
+export TRICU_DB_PATH=/tmp/tricu-local.db
+
+# Import terms from the standard library
+./result/bin/tricu import -f lib/list.tri
+
+# Now use them in eval mode
+echo "not? (t t)" | ./result/bin/tricu eval -t decode
+# Output: t
+
+echo "not? (t t t)" | ./result/bin/tricu eval -t decode
+# Output: Stem Leaf
+
+echo "equal? (t t) (t t t)" | ./result/bin/tricu eval -t decode
+# Output: t
+
+# Check what's in the store
+./result/bin/tricu
+t> !definitions
+```
+
+Without `TRICU_DB_PATH` set, `eval` uses only the terms defined in the input file(s).
+
+## 11. Development Tips
+
+- **REPL:** `nix run .#` starts the interactive tricu REPL.
- **Evaluate files:** `nix run .# -- eval -f demos/equality.tri`
- **GHC options:** `-threaded -rtsopts -with-rtsopts=-N` for parallel runtime. Use `-N` RTS flag for multi-core.
- **Upx** is in the devShell for binary compression if needed.
+
+## 12. Viewing Haskell Dependency Docs from Nix
+
+When you need Haddock documentation for a Haskell dependency available in Nixpkgs, build the package's `doc` output directly with `^doc`.
+
+Example:
+
+Replace `megaparsec` with the dependency name you need:
+
+```sh
+nix build "nixpkgs#haskellPackages.${pkg}^doc"
+```
+
+View the available documentation files:
+
+```sh
+find ./result-doc -type f \( -name '*.html' -o -name '*.haddock' \) | sort
+```
diff --git a/README.md b/README.md
@@ -6,14 +6,12 @@ tricu (pronounced "tree-shoe") is a programming language experiment in Haskell.
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
+I have fully embraced the slopmachine (LLM-assisted development) for this project. Nothing is stable or sacred. We will discover sanity at the end of the journey but we won't strive for it until then.
+
## Acknowledgements
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda.
-## Versioning
-
-This really is a repo for experimentation so I'm not doing anything sane with the versioning for now. If I decide to stabilize the project we'll start anew at 2.0.
-
## REPL examples
```
diff --git a/ext/bundle-runtime-profile-v1.md b/ext/bundle-runtime-profile-v1.md
@@ -0,0 +1,49 @@
+1. Scope
+ This profile defines the minimum required behavior for runtimes that execute tricu bundles.
+
+2. Non-goals
+ No tricu source parsing.
+ No lambda elimination.
+ No module system.
+ No package manager.
+ No local DB requirement.
+ No authoring names beyond bundle exports.
+
+3. Required bundle sections
+ Header
+ Manifest/exports
+ Merkle nodes
+
+4. Optional/skippable sections
+ Source, debug, package metadata, signatures, provenance, etc.
+
+5. Entrypoint selection
+ Explicit export name first.
+ Else export named main.
+ Else single default root.
+ Else error.
+
+6. Node payload format
+ Leaf/Stem/Fork byte layouts.
+
+7. Hash verification
+ Domain string and payload hashing rules.
+
+8. Closure verification
+ All referenced child hashes must exist.
+
+9. Runtime representation
+ Suggested JS representation, but not normative.
+
+10. Reduction semantics
+ The six Tree Calculus apply rules.
+
+11. Codecs for v1
+ Raw tree required.
+ Maybe string/bool optional or experimental.
+
+12. Required error cases
+ Bad magic/version, missing export, hash mismatch, malformed payload, missing child.
+
+13. Test fixtures
+ List of bundles the implementation must pass.
diff --git a/ext/js/package.json b/ext/js/package.json
@@ -0,0 +1,17 @@
+{
+ "name": "arborix-runtime",
+ "version": "0.1.0",
+ "description": "Arborix portable bundle runtime — JavaScript reference implementation",
+ "type": "module",
+ "main": "src/bundle.js",
+ "bin": {
+ "arborix-run": "src/cli.js"
+ },
+ "scripts": {
+ "test": "node --test test/*.test.js",
+ "inspect": "node src/cli.js inspect",
+ "run": "node src/cli.js run"
+ },
+ "keywords": ["arborix", "tree-calculus", "trie", "runtime"],
+ "license": "MIT"
+}
diff --git a/ext/js/src/bundle.js b/ext/js/src/bundle.js
@@ -0,0 +1,188 @@
+/**
+ * bundle.js — Parse an Arborix portable bundle binary into a JavaScript object.
+ *
+ * Format (v1):
+ * Header (32 bytes):
+ * Magic 8B "ARBORIX\0"
+ * Major 2B u16 BE (must be 1)
+ * Minor 2B u16 BE
+ * SectionCount 4B u32 BE
+ * Flags 8B u64 BE
+ * DirOffset 8B u64 BE
+ * Section Directory (SectionCount × 60 bytes):
+ * Type 4B u32 BE
+ * Version 2B u16 BE
+ * Flags 2B u16 BE (bit 0 = critical)
+ * Compression 2B u16 BE
+ * DigestAlgo 2B u16 BE
+ * Offset 8B u64 BE
+ * Length 8B u64 BE
+ * SHA256Digest 32B raw
+ */
+
+import { createHash } from "node:crypto";
+
+// ── Constants ───────────────────────────────────────────────────────────────
+
+const MAGIC = Buffer.from([0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00]); // "ARBORIX\0"
+const HEADER_LENGTH = 32;
+const SECTION_ENTRY_LENGTH = 60;
+const SECTION_MANIFEST = 1;
+const SECTION_NODES = 2;
+const FLAG_CRITICAL = 0x0001;
+const COMPRESSION_NONE = 0;
+const DIGEST_SHA256 = 1;
+const MAJOR_VERSION = 1;
+const MINOR_VERSION = 0;
+
+// ── Helpers ─────────────────────────────────────────────────────────────────
+
+function readU16BE(buf, offset) {
+ return buf.readUint16BE(offset);
+}
+function readU32BE(buf, offset) {
+ return buf.readUint32BE(offset);
+}
+function readU64BE(buf, offset) {
+ return buf.readBigUInt64BE(offset);
+}
+
+function sha256(data) {
+ return createHash("sha256").update(data).digest();
+}
+
+// ── Public API ──────────────────────────────────────────────────────────────
+
+/**
+ * Parse a bundle Buffer into a Bundle object.
+ *
+ * Returns { version, sectionCount, sections } where sections maps
+ * section type numbers to parsed section info (offset, length, data).
+ */
+export function parseBundle(buffer) {
+ if (buffer.length < HEADER_LENGTH) {
+ throw new Error("bundle too short for header");
+ }
+
+ // Check magic
+ if (!buffer.slice(0, 8).equals(MAGIC)) {
+ throw new Error("invalid magic: expected ARBORIX\\0");
+ }
+
+ // Parse header
+ const major = readU16BE(buffer, 8);
+ const minor = readU16BE(buffer, 10);
+ const sectionCount = readU32BE(buffer, 12);
+
+ if (major !== MAJOR_VERSION) {
+ throw new Error(
+ `unsupported bundle major version: ${major} (expected ${MAJOR_VERSION})`
+ );
+ }
+
+ const dirOffset = Number(readU64BE(buffer, 24));
+
+ // Parse section directory
+ const dirStart = dirOffset;
+ const dirEnd = dirStart + sectionCount * SECTION_ENTRY_LENGTH;
+
+ if (buffer.length < dirEnd) {
+ throw new Error("bundle truncated in section directory");
+ }
+
+ const entries = [];
+ for (let i = 0; i < sectionCount; i++) {
+ const off = dirStart + i * SECTION_ENTRY_LENGTH;
+ const entry = {
+ type: readU32BE(buffer, off),
+ version: readU16BE(buffer, off + 4),
+ flags: readU16BE(buffer, off + 6),
+ compression: readU16BE(buffer, off + 8),
+ digestAlgorithm: readU16BE(buffer, off + 10),
+ offset: Number(readU64BE(buffer, off + 12)),
+ length: Number(readU64BE(buffer, off + 20)),
+ digest: buffer.slice(off + 28, off + 28 + 32),
+ };
+ entries.push(entry);
+ }
+
+ // Validate sections
+ for (const entry of entries) {
+ const isCritical = (entry.flags & FLAG_CRITICAL) !== 0;
+ const isKnown =
+ entry.type === SECTION_MANIFEST || entry.type === SECTION_NODES;
+ if (isCritical && !isKnown) {
+ throw new Error(`unknown critical section type: ${entry.type}`);
+ }
+ if (entry.compression !== COMPRESSION_NONE) {
+ throw new Error(
+ `unsupported compression codec in section ${entry.type}`
+ );
+ }
+ if (entry.digestAlgorithm !== DIGEST_SHA256) {
+ throw new Error(
+ `unsupported digest algorithm in section ${entry.type}`
+ );
+ }
+ }
+
+ // Verify section digests and extract data
+ const sections = new Map();
+ for (const entry of entries) {
+ if (entry.offset < 0 || entry.length < 0) {
+ throw new Error(`section ${entry.type} has negative offset/length`);
+ }
+ if (buffer.length < entry.offset + entry.length) {
+ throw new Error(
+ `section ${entry.type} extends beyond bundle end`
+ );
+ }
+
+ const data = buffer.slice(entry.offset, entry.offset + entry.length);
+
+ // Verify digest
+ const computed = sha256(data);
+ if (!computed.equals(entry.digest)) {
+ throw new Error(
+ `section digest mismatch for section type ${entry.type}`
+ );
+ }
+
+ sections.set(entry.type, {
+ ...entry,
+ data,
+ });
+ }
+
+ // Check required sections
+ if (!sections.has(SECTION_MANIFEST)) {
+ throw new Error("missing required section: manifest");
+ }
+ if (!sections.has(SECTION_NODES)) {
+ throw new Error("missing required section: nodes");
+ }
+
+ return {
+ version: `${major}.${minor}`,
+ sectionCount,
+ sections,
+ };
+}
+
+/**
+ * Convenience: parse and return just the manifest JSON.
+ */
+export function parseManifest(buffer) {
+ const bundle = parseBundle(buffer);
+ const manifestEntry = bundle.sections.get(SECTION_MANIFEST);
+ return JSON.parse(manifestEntry.data.toString("utf-8"));
+}
+
+/**
+ * Convenience: parse and return the node section binary.
+ */
+export function parseNodeSection(buffer) {
+ const bundle = parseBundle(buffer);
+ const nodesEntry = bundle.sections.get(SECTION_NODES);
+ return nodesEntry.data;
+}
diff --git a/ext/js/src/cli.js b/ext/js/src/cli.js
@@ -0,0 +1,249 @@
+#!/usr/bin/env node
+/**
+ * cli.js — Minimal CLI for inspecting and running Arborix bundles.
+ *
+ * Usage:
+ * node cli.js inspect <bundle>
+ * node cli.js run <bundle> [exportName] [input]
+ */
+
+import { readFileSync } from "node:fs";
+import { parseBundle, parseManifest } from "./bundle.js";
+import { parseNodeSection as parseNodeSectionMerkle } from "./merkle.js";
+import {
+ validateManifest,
+ selectExport,
+ printManifestInfo,
+} from "./manifest.js";
+import { parseNodeSection as parseNodeSectionBundle } from "./bundle.js";
+import {
+ verifyNodeHashes,
+ verifyClosure,
+ verifyRootClosure,
+} from "./merkle.js";
+import { isTree, apply, triage, isFork, isStem } from "./tree.js";
+import { decodeResult, formatTree } from "./codecs.js";
+
+// ── Commands ────────────────────────────────────────────────────────────────
+
+function cmdInspect(bundlePath) {
+ const buffer = readFileSync(bundlePath);
+ try {
+ const manifest = parseManifest(buffer);
+ validateManifest(manifest);
+
+ const nodeSectionBytes = parseNodeSectionBundle(buffer);
+ const { nodeMap } = parseNodeSectionMerkle(nodeSectionBytes);
+
+ console.log(`Bundle: ${bundlePath}`);
+ console.log("");
+
+ printManifestInfo(manifest, " ");
+
+ console.log(` Nodes: ${nodeMap.size}`);
+
+ // Verify hashes
+ const { verified: hashesOk, mismatches } = verifyNodeHashes(nodeMap);
+ console.log(` Hash verification: ${hashesOk ? "OK" : "FAIL"}`);
+ for (const m of mismatches) {
+ console.log(` MISMATCH ${m.type} ${m.hash.substring(0, 16)}... expected ${m.expected.substring(0, 16)}...`);
+ }
+
+ // Verify closure
+ const { complete: closureOk, missing } = verifyClosure(nodeMap);
+ console.log(` Closure verification: ${closureOk ? "OK" : "FAIL"}`);
+ for (const m of missing) {
+ console.log(` MISSING ${m.parent.substring(0, 16)}... → ${m.child.substring(0, 16)}...`);
+ }
+
+ // Verify root closure for each export
+ for (const exp of manifest.exports || []) {
+ const { complete, missingRoots } = verifyRootClosure(
+ nodeMap,
+ exp.root
+ );
+ if (!complete) {
+ console.log(
+ ` Root closure for "${exp.name}": FAIL — missing: ${missingRoots
+ .map((r) => r.substring(0, 16) + "...")
+ .join(", ")}`
+ );
+ }
+ }
+
+ console.log("");
+ console.log("Inspection complete.");
+ } catch (e) {
+ console.error(`Error: ${e.message}`);
+ process.exit(1);
+ }
+}
+
+function cmdRun(bundlePath, exportName, inputArg) {
+ const buffer = readFileSync(bundlePath);
+ let result;
+ try {
+ const manifest = parseManifest(buffer);
+ validateManifest(manifest);
+
+ const selectedExport = selectExport(manifest, exportName);
+
+ const nodeSectionBytes = parseNodeSectionBundle(buffer);
+ const { nodeMap } = parseNodeSectionMerkle(nodeSectionBytes);
+
+ // Verify hashes
+ const { verified, mismatches } = verifyNodeHashes(nodeMap);
+ if (!verified) {
+ console.error(
+ `Node hash mismatch:\n ${mismatches
+ .map((m) => ` ${m.type}: ${m.hash} (expected ${m.expected})`)
+ .join("\n")}`
+ );
+ process.exit(1);
+ }
+
+ // Reconstruct the tree for the selected export
+ const root = buildTreeFromNodeMap(nodeMap, selectedExport.root);
+ if (!isTree(root)) {
+ console.error("Reconstructed root is not a valid tree value");
+ process.exit(1);
+ }
+
+ // Apply input if provided
+ let term = root;
+ if (inputArg !== undefined) {
+ // TODO: parse input (string/number) into a tree
+ // For now, just run the term as-is
+ }
+
+ // Reduce with fuel limit
+ const finalTerm = reduce(term, 1_000_000);
+
+ // Print result as tree calculus form
+ console.log(formatTree(finalTerm));
+ } catch (e) {
+ console.error(`Error: ${e.message}`);
+ process.exit(1);
+ }
+}
+
+// ── Tree reconstruction ─────────────────────────────────────────────────────
+
+/**
+ * Reconstruct a tree from a node map.
+ *
+ * Node map: Map<hexHash, { type, childHash?, leftHash?, rightHash? }>
+ *
+ * Returns the tree representation: [] for Leaf, [child] for Stem, [right, left] for Fork.
+ * Uses memoization to avoid re-processing nodes.
+ */
+export function buildTreeFromNodeMap(nodeMap, hash, memo = new Map()) {
+ if (memo.has(hash)) return memo.get(hash);
+
+ const node = nodeMap.get(hash);
+ if (!node) {
+ throw new Error(`missing node in bundle: ${hash}`);
+ }
+
+ let tree;
+ switch (node.type) {
+ case "leaf":
+ tree = [];
+ break;
+ case "stem":
+ tree = [buildTreeFromNodeMap(nodeMap, node.childHash, memo)];
+ break;
+ case "fork":
+ tree = [
+ buildTreeFromNodeMap(nodeMap, node.rightHash, memo),
+ buildTreeFromNodeMap(nodeMap, node.leftHash, memo),
+ ];
+ break;
+ default:
+ throw new Error(`unknown node type: ${node.type}`);
+ }
+
+ memo.set(hash, tree);
+ return tree;
+}
+
+// ── Reduction ───────────────────────────────────────────────────────────────
+
+/**
+ * Reduce a term to normal form with a fuel limit.
+ * Uses the stack-based approach from the TS evaluator.
+ */
+export function reduce(term, fuel) {
+ const stack = [term];
+ let remaining = fuel;
+
+ while (stack.length >= 2 && remaining-- > 0) {
+ // Pop right (top), then left
+ const b = stack.pop(); // right
+ const a = stack.pop(); // left
+
+ if (stack.length >= 2) {
+ // Push a back for potential further reduction
+ stack.push(a);
+ }
+
+ const result = apply(a, b);
+
+ if (isTree(result)) {
+ // If result is a value, push it. But if it's a Fork/Stem,
+ // we need to push its components for further reduction.
+ if (isFork(result)) {
+ // Push right first (so it's popped second), then left
+ stack.push(result[1]); // left
+ stack.push(result[0]); // right
+ } else if (isStem(result)) {
+ stack.push(result[0]); // child
+ } else {
+ stack.push(result); // Leaf
+ }
+ } else {
+ // Not a tree — push as-is (shouldn't happen after buildTree)
+ stack.push(result);
+ }
+ }
+
+ if (remaining <= 0) {
+ throw new Error("reduction step limit exceeded");
+ }
+
+ if (stack.length === 1) {
+ return stack[0];
+ }
+ return stack[0]; // fallback
+}
+
+// ── Main ────────────────────────────────────────────────────────────────────
+
+const args = process.argv.slice(2);
+const command = args[0];
+
+switch (command) {
+ case "inspect": {
+ if (args.length < 2) {
+ console.error("Usage: node cli.js inspect <bundle>");
+ process.exit(1);
+ }
+ cmdInspect(args[1]);
+ break;
+ }
+ case "run": {
+ if (args.length < 2) {
+ console.error("Usage: node cli.js run <bundle> [exportName] [input]");
+ process.exit(1);
+ }
+ cmdRun(args[1], args[2], args[3]);
+ break;
+ }
+ default:
+ console.log("Arborix JS Runtime");
+ console.log("");
+ console.log("Usage:");
+ console.log(" node cli.js inspect <bundle>");
+ console.log(" node cli.js run <bundle> [exportName] [input]");
+ break;
+}
diff --git a/ext/js/src/codecs.js b/ext/js/src/codecs.js
@@ -0,0 +1,135 @@
+/**
+ * codecs.js — Minimal codecs for decoding tree results.
+ *
+ * Implements: decodeResult (from Research.hs)
+ * - Leaf → "t"
+ * - Numbers: toNumber
+ * - Strings: toString
+ * - Lists: toList
+ * - Fallback: raw tree format
+ */
+
+// ── toNumber ────────────────────────────────────────────────────────────────
+
+/**
+ * Decode a tree as a binary number (big-endian).
+ * Leaf = 0, Fork(Leaf, rest) = 2*n, Fork(Stem Leaf, rest) = 2*n+1.
+ */
+export function toNumber(t) {
+ if (!Array.isArray(t)) return null;
+ if (t.length === 0) return 0; // Leaf = 0
+ if (t.length !== 2) return null; // must be Fork
+
+ const [right, left] = t;
+ // Fork structure: [right, left]
+ // left child determines bit: Leaf = 0, Stem(Leaf) = 1
+ let bit;
+ if (Array.isArray(left) && left.length === 0) {
+ bit = 0; // Leaf
+ } else if (Array.isArray(left) && left.length === 1) {
+ const child = left[0];
+ if (Array.isArray(child) && child.length === 0) {
+ bit = 1; // Stem(Leaf) = 1
+ } else {
+ return null; // Stem of something other than Leaf
+ }
+ } else {
+ return null;
+ }
+
+ const rest = toNumber(right);
+ if (rest === null) return null;
+
+ return bit + 2 * rest;
+}
+
+// ── toString ────────────────────────────────────────────────────────────────
+
+/**
+ * Decode a tree as a list of numbers (characters).
+ * Fork(x, rest) = x : list.
+ */
+export function toList(t) {
+ if (!Array.isArray(t)) return null;
+ if (t.length === 0) return []; // Leaf = empty list
+ if (t.length !== 2) return null; // must be Fork
+
+ const [right, left] = t;
+ const rest = toList(right);
+ if (rest === null) return null;
+
+ return [left, ...rest];
+}
+
+/**
+ * Decode a tree as a string.
+ */
+export function toString(t) {
+ const list = toList(t);
+ if (list === null) return null;
+ try {
+ return list.map((ch) => String.fromCharCode(ch)).join("");
+ } catch {
+ return null;
+ }
+}
+
+// ── decodeResult ────────────────────────────────────────────────────────────
+
+/**
+ * Decode a tree result using multiple strategies:
+ * 1. Leaf → "t"
+ * 2. String (if all chars are printable)
+ * 3. Number
+ * 4. List
+ * 5. Raw tree format
+ */
+export function decodeResult(t) {
+ if (!Array.isArray(t)) {
+ return String(t);
+ }
+
+ // Leaf
+ if (t.length === 0) {
+ return "t";
+ }
+
+ // Try string first (list of char codes)
+ const list = toList(t);
+ if (list !== null && list.length > 0) {
+ const str = list.map((n) => {
+ if (n < 32 || n > 126) return null;
+ return String.fromCharCode(n);
+ }).join("");
+ if (str) return `"${str}"`;
+ }
+
+ // Try number
+ const num = toNumber(t);
+ if (num !== null) {
+ return String(num);
+ }
+
+ // Try list (elements are trees)
+ if (t.length === 2) {
+ const elements = toList(t);
+ if (elements !== null) {
+ const decoded = elements.map((e) => decodeResult(e));
+ return `[${decoded.join(", ")}]`;
+ }
+ }
+
+ // Raw tree format
+ return formatTree(t);
+}
+
+/**
+ * Format a tree as a parenthesized expression.
+ */
+export function formatTree(t) {
+ if (!Array.isArray(t)) return String(t);
+ if (t.length === 0) return "Leaf";
+ if (t.length === 1) return `Stem(${formatTree(t[0])})`;
+ if (t.length === 2) return `Fork(${formatTree(t[1])}, ${formatTree(t[0])})`;
+ return `[${t.map(formatTree).join(", ")}]`;
+}
diff --git a/ext/js/src/manifest.js b/ext/js/src/manifest.js
@@ -0,0 +1,167 @@
+/**
+ * manifest.js — Minimal manifest parsing and export lookup.
+ *
+ * The manifest is a JSON object with fields:
+ * schema, bundleType, tree, runtime, closure, roots, exports,
+ * imports, sections, metadata
+ *
+ * We parse only what we need for runtime entrypoint selection.
+ */
+
+/**
+ * Validate the manifest against the runtime profile requirements.
+ * Throws on violation.
+ */
+export function validateManifest(manifest) {
+ if (manifest.schema !== "arborix.bundle.manifest.v1") {
+ throw new Error(
+ `unsupported manifest schema: ${manifest.schema}`
+ );
+ }
+ if (manifest.bundleType !== "tree-calculus-executable-object") {
+ throw new Error(
+ `unsupported bundle type: ${manifest.bundleType}`
+ );
+ }
+
+ const tree = manifest.tree;
+ if (tree.calculus !== "tree-calculus.v1") {
+ throw new Error(`unsupported calculus: ${tree.calculus}`);
+ }
+ if (tree.nodeHash.algorithm !== "sha256") {
+ throw new Error(
+ `unsupported node hash algorithm: ${tree.nodeHash.algorithm}`
+ );
+ }
+ if (tree.nodeHash.domain !== "tricu.merkle.node.v1" && tree.nodeHash.domain !== "arborix.merkle.node.v1") {
+ throw new Error(
+ `unsupported node hash domain: ${tree.nodeHash.domain}`
+ );
+ }
+ if (tree.nodePayload !== "arborix.merkle.payload.v1") {
+ throw new Error(`unsupported node payload: ${tree.nodePayload}`);
+ }
+
+ const runtime = manifest.runtime;
+ if (runtime.semantics !== "tree-calculus.v1") {
+ throw new Error(`unsupported runtime semantics: ${runtime.semantics}`);
+ }
+ if (runtime.abi !== "arborix.abi.tree.v1") {
+ throw new Error(`unsupported runtime ABI: ${runtime.abi}`);
+ }
+ if (runtime.capabilities && runtime.capabilities.length > 0) {
+ throw new Error(
+ `host/runtime capabilities not supported: ${runtime.capabilities.join(", ")}`
+ );
+ }
+
+ if (manifest.closure !== "complete") {
+ throw new Error("bundle v1 requires closure = complete");
+ }
+ if (manifest.imports && manifest.imports.length > 0) {
+ throw new Error("bundle v1 requires an empty imports list");
+ }
+ if (!manifest.roots || manifest.roots.length === 0) {
+ throw new Error("manifest has no roots");
+ }
+ if (!manifest.exports || manifest.exports.length === 0) {
+ throw new Error("manifest has no exports");
+ }
+
+ for (const exp of manifest.exports) {
+ if (!exp.name) {
+ throw new Error("manifest export has empty name");
+ }
+ if (!exp.root) {
+ throw new Error("manifest export has empty root");
+ }
+ }
+}
+
+/**
+ * Select an export hash given a requested name.
+ *
+ * Selection strategy:
+ * 1. Explicit export name
+ * 2. Export named "main"
+ * 3. Single export (auto-select)
+ * 4. Error if multiple exports and no "main"
+ */
+export function selectExport(manifest, requestedName) {
+ const exports = manifest.exports || [];
+
+ // Strategy 1: explicit name
+ if (requestedName) {
+ const found = exports.find((e) => e.name === requestedName);
+ if (found) {
+ return found;
+ }
+ throw new Error(
+ `requested export "${requestedName}" not found. Available: ${exports.map((e) => e.name).join(", ")}`
+ );
+ }
+
+ // Strategy 2: prefer "main"
+ const mainExport = exports.find((e) => e.name === "main");
+ if (mainExport) {
+ return mainExport;
+ }
+
+ // Strategy 3: single export
+ if (exports.length === 1) {
+ return exports[0];
+ }
+
+ // Strategy 4: multiple exports, require explicit
+ throw new Error(
+ `multiple exports available but none named "main": ${exports.map((e) => e.name).join(", ")}. Specify an export name.`
+ );
+}
+
+/**
+ * Get all root hashes from the manifest.
+ */
+export function getRootHashes(manifest) {
+ return (manifest.roots || []).map((r) => r.hash);
+}
+
+/**
+ * Get all export names.
+ */
+export function getExportNames(manifest) {
+ return (manifest.exports || []).map((e) => e.name);
+}
+
+/**
+ * Print manifest summary info.
+ */
+export function printManifestInfo(manifest, indent = "") {
+ const tree = manifest.tree;
+ const runtime = manifest.runtime;
+
+ console.log(`${indent}Schema: ${manifest.schema}`);
+ console.log(`${indent}Bundle type: ${manifest.bundleType}`);
+ console.log(`${indent}Closure: ${manifest.closure}`);
+ console.log(`${indent}Tree calculus: ${tree.calculus}`);
+ console.log(`${indent}Hash algo: ${tree.nodeHash.algorithm}`);
+ console.log(`${indent}Hash domain: ${tree.nodeHash.domain}`);
+ console.log(`${indent}Runtime: ${runtime.semantics}`);
+ console.log(`${indent}ABI: ${runtime.abi}`);
+ console.log(`${indent}Evaluation: ${runtime.evaluation || "N/A"}`);
+ console.log("");
+ console.log(`${indent}Roots (${getRootHashes(manifest).length}):`);
+ for (const root of getRootHashes(manifest)) {
+ console.log(`${indent} ${root.substring(0, 16)}...`);
+ }
+ console.log("");
+ console.log(`${indent}Exports (${getExportNames(manifest).length}):`);
+ for (const name of getExportNames(manifest)) {
+ console.log(`${indent} ${name}`);
+ }
+
+ const meta = manifest.metadata;
+ if (meta && meta.createdBy) {
+ console.log("");
+ console.log(`${indent}Created by: ${meta.createdBy}`);
+ }
+}
diff --git a/ext/js/src/merkle.js b/ext/js/src/merkle.js
@@ -0,0 +1,276 @@
+/**
+ * merkle.js — Node payload decoding and hash verification.
+ *
+ * Node payload format:
+ * Leaf: 0x00
+ * Stem: 0x01 || child_hash (32 bytes raw)
+ * Fork: 0x02 || left_hash (32 bytes raw) || right_hash (32 bytes raw)
+ *
+ * Hash computation:
+ * hash = SHA256( "tricu.merkle.node.v1" || 0x00 || node_payload )
+ */
+
+import { createHash } from "node:crypto";
+
+// ── Constants ───────────────────────────────────────────────────────────────
+
+const DOMAIN_TAG = "tricu.merkle.node.v1";
+const HASH_LENGTH = 32; // raw hash bytes
+const HEX_LENGTH = 64; // hex-encoded hash length
+
+// ── Helpers ─────────────────────────────────────────────────────────────────
+
+function rawToHex(buf) {
+ if (buf.length !== HASH_LENGTH) {
+ throw new Error(`raw hash must be ${HASH_LENGTH} bytes, got ${buf.length}`);
+ }
+ return buf.toString("hex");
+}
+
+function hexToRaw(hex) {
+ const buf = Buffer.from(hex, "hex");
+ if (buf.length !== HASH_LENGTH) {
+ throw new Error(`hex hash must decode to ${HASH_LENGTH} bytes`);
+ }
+ return buf;
+}
+
+function sha256(data) {
+ return createHash("sha256").update(data).digest();
+}
+
+function nodeHash(prefix, payload) {
+ return sha256(Buffer.concat([Buffer.from(prefix), Buffer.from([0x00]), payload]));
+}
+
+// ── Node payload types ──────────────────────────────────────────────────────
+
+/**
+ * Deserialize a node payload into { type, childHash, leftHash, rightHash }.
+ *
+ * type: "leaf" | "stem" | "fork"
+ * childHash: hex string (for stem)
+ * leftHash: hex string (for fork)
+ * rightHash: hex string (for fork)
+ */
+export function deserializePayload(payload) {
+ if (payload.length === 0) {
+ throw new Error("empty payload");
+ }
+
+ const type = payload.readUInt8(0);
+
+ switch (type) {
+ case 0x00:
+ if (payload.length !== 1) {
+ throw new Error(
+ `invalid leaf payload: expected 1 byte, got ${payload.length}`
+ );
+ }
+ return { type: "leaf" };
+
+ case 0x01:
+ if (payload.length !== 1 + HASH_LENGTH) {
+ throw new Error(
+ `invalid stem payload: expected ${1 + HASH_LENGTH} bytes, got ${payload.length}`
+ );
+ }
+ return {
+ type: "stem",
+ childHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
+ };
+
+ case 0x02:
+ if (payload.length !== 1 + 2 * HASH_LENGTH) {
+ throw new Error(
+ `invalid fork payload: expected ${1 + 2 * HASH_LENGTH} bytes, got ${payload.length}`
+ );
+ }
+ return {
+ type: "fork",
+ leftHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
+ rightHash: rawToHex(payload.slice(1 + HASH_LENGTH, 1 + 2 * HASH_LENGTH)),
+ };
+
+ default:
+ throw new Error(
+ `invalid merkle node payload: unknown type 0x${type.toString(16)}`
+ );
+ }
+}
+
+/**
+ * Compute the canonical payload bytes for a given tree node structure.
+ */
+export function serializeNode(node) {
+ switch (node.type) {
+ case "leaf":
+ return Buffer.from([0x00]);
+ case "stem":
+ return Buffer.concat([Buffer.from([0x01]), hexToRaw(node.childHash)]);
+ case "fork":
+ return Buffer.concat([
+ Buffer.from([0x02]),
+ hexToRaw(node.leftHash),
+ hexToRaw(node.rightHash),
+ ]);
+ }
+}
+
+/**
+ * Compute the Merkle hash of a node from its type and parameters.
+ */
+export function computeNodeHash(node) {
+ const payload = serializeNode(node);
+ const hash = nodeHash(DOMAIN_TAG, payload);
+ return hash.toString("hex");
+}
+
+// ── Node section parsing ────────────────────────────────────────────────────
+
+/**
+ * Parse the node section binary into a Map<hexHash, { type, payload, node }>.
+ *
+ * Node section format:
+ * nodeCount (8B u64 BE)
+ * entries[]:
+ * hash (32B raw)
+ * payloadLen (4B u32 BE)
+ * payload (payloadLen bytes)
+ */
+export function parseNodeSection(data) {
+ if (data.length < 8) {
+ throw new Error("node section too short for count");
+ }
+
+ const nodeCount = Number(data.readBigUInt64BE(0));
+ let offset = 8;
+
+ const nodeMap = new Map();
+ const errors = [];
+
+ for (let i = 0; i < nodeCount; i++) {
+ // Read hash
+ if (offset + HASH_LENGTH > data.length) {
+ errors.push(`node ${i}: not enough bytes for hash`);
+ break;
+ }
+ const hash = rawToHex(data.slice(offset, offset + HASH_LENGTH));
+ offset += HASH_LENGTH;
+
+ // Read payload length
+ if (offset + 4 > data.length) {
+ errors.push(`node ${i} (${hash}): not enough bytes for payload length`);
+ break;
+ }
+ const payloadLen = data.readUint32BE(offset);
+ offset += 4;
+
+ // Read payload
+ if (offset + payloadLen > data.length) {
+ errors.push(`node ${i} (${hash}): payload extends beyond section end`);
+ break;
+ }
+ const payload = data.slice(offset, offset + payloadLen);
+ offset += payloadLen;
+
+ // Deserialize payload
+ let node;
+ try {
+ node = deserializePayload(payload);
+ } catch (e) {
+ errors.push(`node ${i} (${hash}): ${e.message}`);
+ continue;
+ }
+
+ nodeMap.set(hash, {
+ hash,
+ payload,
+ ...node,
+ });
+ }
+
+ if (errors.length > 0) {
+ throw new Error(
+ `node section parse errors:\n ${errors.join("\n ")}`
+ );
+ }
+
+ return { nodeMap, count: nodeCount };
+}
+
+// ── Verification ────────────────────────────────────────────────────────────
+
+/**
+ * Verify all node hashes match their payloads.
+ * Returns { verified, mismatches }
+ */
+export function verifyNodeHashes(nodeMap) {
+ const mismatches = [];
+
+ for (const [hash, node] of nodeMap) {
+ const expected = computeNodeHash(node);
+ if (hash !== expected) {
+ mismatches.push({
+ hash,
+ expected,
+ type: node.type,
+ });
+ }
+ }
+
+ return { verified: mismatches.length === 0, mismatches };
+}
+
+/**
+ * Verify that all child references exist in the node map (closure).
+ * Returns { complete, missing } where missing is an array of { parent, child }.
+ */
+export function verifyClosure(nodeMap) {
+ const missing = [];
+
+ for (const [hash, node] of nodeMap) {
+ if (node.type === "stem") {
+ if (!nodeMap.has(node.childHash)) {
+ missing.push({ parent: hash, child: node.childHash });
+ }
+ } else if (node.type === "fork") {
+ if (!nodeMap.has(node.leftHash)) {
+ missing.push({ parent: hash, child: node.leftHash });
+ }
+ if (!nodeMap.has(node.rightHash)) {
+ missing.push({ parent: hash, child: node.rightHash });
+ }
+ }
+ }
+
+ return { complete: missing.length === 0, missing };
+}
+
+/**
+ * Verify closure for a specific root hash (transitive reachability).
+ * Returns { complete, missingRoots }.
+ */
+export function verifyRootClosure(nodeMap, rootHash) {
+ const visited = new Set();
+ const missingRoots = [];
+
+ function visit(hash) {
+ if (visited.has(hash)) return;
+ if (!nodeMap.has(hash)) {
+ missingRoots.push(hash);
+ return;
+ }
+ visited.add(hash);
+ const node = nodeMap.get(hash);
+ if (node.type === "stem") {
+ visit(node.childHash);
+ } else if (node.type === "fork") {
+ visit(node.leftHash);
+ visit(node.rightHash);
+ }
+ }
+
+ visit(rootHash);
+ return { complete: missingRoots.length === 0, missingRoots };
+}
diff --git a/ext/js/src/tree.js b/ext/js/src/tree.js
@@ -0,0 +1,125 @@
+/**
+ * tree.js — Runtime tree representation.
+ *
+ * The JS tree uses a simple array representation matching the
+ * TypeScript reference evaluator:
+ *
+ * Leaf = []
+ * Stem = [child] (array length === 1)
+ * Fork = [right, left] (array length === 2)
+ *
+ * This is a "flattened stack" representation: when reduced, terms
+ * become arrays and the evaluator pops three elements at a time.
+ */
+
+/**
+ * Check if a value is a Leaf (empty array).
+ */
+export function isLeaf(t) {
+ return Array.isArray(t) && t.length === 0;
+}
+
+/**
+ * Check if a value is a Stem (single element array).
+ */
+export function isStem(t) {
+ return Array.isArray(t) && t.length === 1;
+}
+
+/**
+ * Check if a value is a Fork (two element array).
+ */
+export function isFork(t) {
+ return Array.isArray(t) && t.length === 2;
+}
+
+/**
+ * Check if a value is a valid tree calculus value (Leaf, Stem, or Fork).
+ */
+export function isTree(t) {
+ return isLeaf(t) || isStem(t) || isFork(t);
+}
+
+/**
+ * Triage a tree: classify it as Leaf/Stem/Fork.
+ * The tree must be in normal form (no reducible redexes).
+ *
+ * Returns { kind: "leaf"|"stem"|"fork", ...rest }
+ */
+export function triage(t) {
+ if (!Array.isArray(t)) {
+ throw new Error("not a tree (not an array)");
+ }
+ if (t.length === 0) return { kind: "leaf" };
+ if (t.length === 1) return { kind: "stem", child: t[0] };
+ if (t.length === 2) return { kind: "fork", right: t[0], left: t[1] };
+ throw new Error(`not a value/binary tree: length ${t.length}`);
+}
+
+/**
+ * Apply the Tree Calculus apply rules.
+ *
+ * apply(a, b) computes the application of term a to term b.
+ *
+ * Rules:
+ * apply(Fork(Leaf, a), _) = a
+ * apply(Fork(Stem(a), b), c) = apply(apply(a, c), apply(b, c))
+ * apply(Fork(Fork, _, _), Leaf) = left of inner Fork
+ * apply(Fork(Fork, _, _), Stem) = right of inner Fork
+ * apply(Fork(Fork, _, _), Fork) = apply(apply(c, u), v) where c=Fork(u,v)
+ * apply(Leaf, b) = Stem(b)
+ * apply(Stem(a), b) = Fork(a, b)
+ *
+ * For Fork, the inner structure is [right, left], so:
+ * a = right, b = left
+ */
+export function apply(a, b) {
+ // apply(Fork(Leaf, a), _) = a
+ // Fork = [right, left] = [Leaf, a] → left child is Leaf
+ if (isFork(a) && isLeaf(a[1])) {
+ return a[0]; // return right child
+ }
+
+ // apply(Fork(Stem(a), b), c)
+ if (isFork(a) && isStem(a[1])) {
+ const stemChild = a[1][0]; // left child of fork
+ const right = a[0]; // right child of fork
+ const innerA = stemChild;
+ const innerB = right;
+ const appliedA = apply(innerA, b);
+ const appliedB = apply(innerB, b);
+ return apply(appliedA, appliedB);
+ }
+
+ // apply(Fork(Fork, _, _), Leaf)
+ if (isFork(a) && isFork(a[1]) && isLeaf(b)) {
+ return a[1][0]; // right child of inner fork (which is left child)
+ }
+
+ // apply(Fork(Fork, _, _), Stem)
+ if (isFork(a) && isFork(a[1]) && isStem(b)) {
+ return a[1][1]; // left child of inner fork
+ }
+
+ // apply(Fork(Fork, _, _), Fork)
+ if (isFork(a) && isFork(a[1]) && isFork(b)) {
+ // b = Fork(u, v) = [v, u]
+ const u = b[0];
+ const v = b[1];
+ // apply(apply(c, u), v) where c = inner fork
+ const applied = apply(apply(a[1], u), v);
+ return applied;
+ }
+
+ // apply(Leaf, b) = Stem(b)
+ if (isLeaf(a)) {
+ return [b];
+ }
+
+ // apply(Stem(a), b) = Fork(a, b)
+ if (isStem(a)) {
+ return [b, a[0]]; // [right, left]
+ }
+
+ throw new Error("apply: undefined reduction for terms");
+}
diff --git a/ext/js/test/bundle.test.js b/ext/js/test/bundle.test.js
@@ -0,0 +1,67 @@
+import { readFileSync } from "node:fs";
+import { strictEqual, ok, throws } from "node:assert";
+import { describe, it } from "node:test";
+import {
+ parseBundle,
+ parseManifest,
+} from "../src/bundle.js";
+import {
+ parseNodeSection as bundleParseNodeSection,
+} from "../src/bundle.js";
+import {
+ verifyNodeHashes,
+ parseNodeSection as parseNodes,
+} from "../src/merkle.js";
+
+const fixtureDir = "test/fixtures";
+
+describe("bundle parsing", () => {
+ it("valid bundle parses header and sections", () => {
+ const bundle = parseBundle(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ strictEqual(bundle.version, "1.0");
+ strictEqual(bundle.sectionCount, 2);
+ ok(bundle.sections.has(1)); // manifest
+ ok(bundle.sections.has(2)); // nodes
+ });
+
+ it("parseManifest returns valid JSON", () => {
+ const manifest = parseManifest(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ strictEqual(manifest.schema, "arborix.bundle.manifest.v1");
+ strictEqual(manifest.bundleType, "tree-calculus-executable-object");
+ strictEqual(manifest.closure, "complete");
+ strictEqual(manifest.tree.calculus, "tree-calculus.v1");
+ strictEqual(manifest.tree.nodeHash.algorithm, "sha256");
+ strictEqual(manifest.runtime.semantics, "tree-calculus.v1");
+ strictEqual(manifest.runtime.abi, "arborix.abi.tree.v1");
+ });
+});
+
+describe("hash verification", () => {
+ it("valid bundle nodes verify", () => {
+ const data = bundleParseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ const { verified } = verifyNodeHashes(nodeMap);
+ ok(verified, "all node hashes should verify");
+ });
+});
+
+describe("errors", () => {
+ it("bad magic fails", () => {
+ const buf = Buffer.alloc(32, 0);
+ buf.write("WRONGMAG", 0, 8);
+ throws(() => parseBundle(buf), /invalid magic/);
+ });
+
+ it("unsupported version fails", () => {
+ const buf = Buffer.alloc(32, 0);
+ buf.write("ARBORIX\0", 0, 8);
+ buf.writeUInt16BE(2, 8); // major version 2
+ throws(() => parseBundle(buf), /unsupported bundle major version/);
+ });
+});
diff --git a/ext/js/test/merkle.test.js b/ext/js/test/merkle.test.js
@@ -0,0 +1,148 @@
+import { readFileSync } from "node:fs";
+import { strictEqual, ok } from "node:assert";
+import { describe, it } from "node:test";
+import { parseNodeSection } from "../src/bundle.js";
+import {
+ verifyNodeHashes,
+ verifyClosure,
+ verifyRootClosure,
+ deserializePayload,
+ computeNodeHash,
+} from "../src/merkle.js";
+
+describe("merkle — deserializePayload", () => {
+ it("Leaf (0x00)", () => {
+ const result = deserializePayload(Buffer.from([0x00]));
+ strictEqual(result.type, "leaf");
+ });
+
+ it("Stem (0x01 + 32 bytes)", () => {
+ const childHash = Buffer.alloc(32, 0xab);
+ const payload = Buffer.concat([Buffer.from([0x01]), childHash]);
+ const result = deserializePayload(payload);
+ strictEqual(result.type, "stem");
+ strictEqual(result.childHash, "ab".repeat(32));
+ });
+
+ it("Fork (0x02 + 64 bytes)", () => {
+ const left = Buffer.alloc(32, 0x01);
+ const right = Buffer.alloc(32, 0x02);
+ const payload = Buffer.concat([Buffer.from([0x02]), left, right]);
+ const result = deserializePayload(payload);
+ strictEqual(result.type, "fork");
+ strictEqual(result.leftHash, "01".repeat(32));
+ strictEqual(result.rightHash, "02".repeat(32));
+ });
+
+ it("Leaf with extra bytes fails", () => {
+ throws(() => deserializePayload(Buffer.from([0x00, 0x00])), /invalid leaf/);
+ });
+
+ it("Unknown type fails", () => {
+ throws(() => deserializePayload(Buffer.from([0xff])), /unknown type/);
+ });
+});
+
+describe("merkle — computeNodeHash", () => {
+ it("Leaf hash is correct length", () => {
+ const leaf = { type: "leaf" };
+ const hash = computeNodeHash(leaf);
+ strictEqual(hash.length, 64);
+ });
+});
+
+describe("merkle — node section parsing", () => {
+ const fixtureDir = "test/fixtures";
+
+ it("parses id.tri.bundle with correct node count", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ strictEqual(nodeMap.size, 4);
+ });
+
+ it("parses true.tri.bundle with correct node count", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/true.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ strictEqual(nodeMap.size, 2);
+ });
+});
+
+describe("merkle — hash verification", () => {
+ const fixtureDir = "test/fixtures";
+
+ it("id.tri.bundle nodes all verify", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ const { verified, mismatches } = verifyNodeHashes(nodeMap);
+ ok(verified, "id.tri.bundle node hashes should verify");
+ strictEqual(mismatches.length, 0);
+ });
+
+ it("corrupted node payload fails hash verification", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ // Find a stem node to corrupt
+ let stemKey = null;
+ for (const [key, node] of nodeMap) {
+ if (node.type === "stem") { stemKey = key; break; }
+ }
+ ok(stemKey, "should find a stem node to corrupt");
+ const stem = nodeMap.get(stemKey);
+ // Corrupt the child hash so serializeNode produces a different payload
+ const corrupted = {
+ ...stem,
+ childHash: "00".repeat(32),
+ payload: Buffer.concat([Buffer.from([0x01]), Buffer.alloc(32, 0x00)]),
+ };
+ nodeMap.set(stemKey, corrupted);
+ const { verified, mismatches } = verifyNodeHashes(nodeMap);
+ ok(!verified, "corrupted stem should fail hash verification");
+ ok(mismatches.length > 0, "should have mismatches");
+ });
+});
+
+describe("merkle — closure verification", () => {
+ const fixtureDir = "test/fixtures";
+
+ it("id.tri.bundle has complete closure", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ const { complete, missing } = verifyClosure(nodeMap);
+ ok(complete, "id.tri.bundle should have complete closure");
+ strictEqual(missing.length, 0);
+ });
+
+ it("verifyRootClosure checks transitive reachability", () => {
+ const data = parseNodeSection(
+ readFileSync(`${fixtureDir}/id.tri.bundle`)
+ );
+ const { nodeMap } = parseNodes(data);
+ const rootHash = "039cc9aacf5be78ec1975713e6ad154a36988e3f3df18589b0d0c801d0825d78";
+ const { complete, missingRoots } = verifyRootClosure(nodeMap, rootHash);
+ ok(complete, "root should be reachable");
+ strictEqual(missingRoots.length, 0);
+ });
+});
+
+// Helper import
+import { parseNodeSection as parseNodes } from "../src/merkle.js";
+
+// Helper for throws
+function throws(fn, expected) {
+ try {
+ fn();
+ return false;
+ } catch (e) {
+ return expected.test(e.message);
+ }
+}
diff --git a/ext/js/test/reduce.test.js b/ext/js/test/reduce.test.js
@@ -0,0 +1,80 @@
+import { strictEqual, ok } from "node:assert";
+import { describe, it } from "node:test";
+import { apply, isLeaf, isStem, isFork } from "../src/tree.js";
+import { reduce } from "../src/cli.js";
+
+describe("tree — basic types", () => {
+ it("Leaf is empty array", () => {
+ ok(isLeaf([]));
+ ok(!isStem([]));
+ ok(!isFork([]));
+ });
+
+ it("Stem is single-element array", () => {
+ ok(isStem([[]]));
+ ok(!isLeaf([[]]));
+ });
+
+ it("Fork is two-element array", () => {
+ ok(isFork([[], []]));
+ ok(!isLeaf([[], []]));
+ });
+});
+
+describe("tree — apply rules", () => {
+ // Leaf = [], Stem = [child], Fork = [right, left]
+
+ it("apply(Leaf, b) = Stem(b)", () => {
+ const b = []; // Leaf
+ const result = apply([], b);
+ ok(isStem(result), "Stem(b) should be a Stem");
+ strictEqual(result[0], b);
+ });
+
+ it("apply(Stem(a), b) = Fork(a, b)", () => {
+ const a = []; // Leaf
+ const b = []; // Leaf
+ const result = apply([a], b);
+ ok(isFork(result), "Fork(a, b) should be a Fork");
+ // Fork = [right, left] = [b, a]
+ strictEqual(result[0], b);
+ strictEqual(result[1], a);
+ });
+
+ it("apply(Fork(Leaf, a), _) = a", () => {
+ // Fork(Leaf, a) = [a, Leaf]
+ const a = []; // Leaf
+ const result = apply([a, []], []);
+ strictEqual(result, a);
+ ok(isLeaf(result));
+ });
+});
+
+describe("tree — reduction", () => {
+ it("reduces Leaf to Leaf", () => {
+ const result = reduce([], 100);
+ ok(isLeaf(result));
+ });
+
+ it("reduces Stem Leaf to Stem Leaf", () => {
+ const result = reduce([[]], 100);
+ ok(isStem(result));
+ ok(isLeaf(result[0]));
+ });
+
+ it("reduces Fork Leaf Leaf to Fork Leaf Leaf", () => {
+ const result = reduce([[], []], 100);
+ ok(isFork(result));
+ ok(isLeaf(result[0]));
+ ok(isLeaf(result[1]));
+ });
+
+ it("S combinator applied to Leaf reduces", () => {
+ // S = t (t (t t)) t = Fork (Fork (Fork Leaf Leaf) Leaf) Leaf
+ // In array form: [[[], []], [], []]
+ const s = [[], [[[], []], []]];
+ const leaf = [];
+ const result = reduce([s, leaf], 100);
+ ok(Array.isArray(result), "S Leaf should reduce to an array");
+ });
+});
diff --git a/ext/js/test/run-bundle.test.js b/ext/js/test/run-bundle.test.js
@@ -0,0 +1,84 @@
+import { readFileSync } from "node:fs";
+import { strictEqual, ok, throws } from "node:assert";
+import { describe, it } from "node:test";
+import { parseManifest } from "../src/bundle.js";
+import { parseNodeSection as bundleParseNodeSection } from "../src/bundle.js";
+import { validateManifest, selectExport } from "../src/manifest.js";
+import { verifyNodeHashes, parseNodeSection as parseNodes } from "../src/merkle.js";
+import { buildTreeFromNodeMap } from "../src/cli.js";
+
+const fixtureDir = "test/fixtures";
+
+describe("run bundle — id.tri.bundle", () => {
+ const bundle = readFileSync(`${fixtureDir}/id.tri.bundle`);
+ const manifest = parseManifest(bundle);
+ const nodeSectionData = bundleParseNodeSection(bundle);
+ const { nodeMap } = parseNodes(nodeSectionData);
+
+ it("manifest validates", () => {
+ validateManifest(manifest);
+ });
+
+ it("node hashes verify", () => {
+ const { verified } = verifyNodeHashes(nodeMap);
+ ok(verified);
+ });
+
+ it("export 'id' is selectable", () => {
+ const exp = selectExport(manifest, "id");
+ strictEqual(exp.name, "id");
+ });
+
+ it("tree reconstructs as a Fork", () => {
+ const exp = selectExport(manifest, "id");
+ const tree = buildTreeFromNodeMap(nodeMap, exp.root);
+ ok(Array.isArray(tree));
+ // id = t (t t) = Fork (Stem Leaf) Leaf...
+ // In Haskell: id = S = t (t (t t)) t
+ // This is Fork (Fork (Fork Leaf Leaf) Leaf) Leaf
+ // In array form: [[[], []], [], []]
+ ok(tree.length >= 2, "tree should be a Fork (length >= 2)");
+ });
+});
+
+describe("run bundle — true.tri.bundle", () => {
+ const bundle = readFileSync(`${fixtureDir}/true.tri.bundle`);
+ const manifest = parseManifest(bundle);
+ const nodeSectionData = bundleParseNodeSection(bundle);
+ const { nodeMap } = parseNodes(nodeSectionData);
+
+ it("manifest validates", () => {
+ validateManifest(manifest);
+ });
+
+ it("export 'const' is selectable", () => {
+ const exp = selectExport(manifest, "const");
+ strictEqual(exp.name, "const");
+ });
+
+ it("tree reconstructs", () => {
+ const exp = selectExport(manifest, "const");
+ const tree = buildTreeFromNodeMap(nodeMap, exp.root);
+ ok(Array.isArray(tree));
+ });
+});
+
+describe("run bundle — missing export", () => {
+ const bundle = readFileSync(`${fixtureDir}/id.tri.bundle`);
+ const manifest = parseManifest(bundle);
+
+ it("nonexistent export fails clearly", () => {
+ throws(() => selectExport(manifest, "nonexistent"), /not found/);
+ });
+});
+
+describe("run bundle — auto-select", () => {
+ // true.tri.bundle has only one export, should auto-select
+ const bundle = readFileSync(`${fixtureDir}/true.tri.bundle`);
+ const manifest = parseManifest(bundle);
+
+ it("single export auto-selects", () => {
+ const exp = selectExport(manifest, undefined);
+ ok(exp, "should auto-select the only export");
+ });
+});
diff --git a/src/ContentStore.hs b/src/ContentStore.hs
@@ -4,11 +4,14 @@ import Research
import Control.Monad (foldM, forM_, void)
import Data.ByteString (ByteString)
+import Data.Char (isHexDigit)
import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
+import System.Environment (lookupEnv)
+import System.Exit (die)
import System.FilePath ((</>), takeDirectory)
import qualified Data.Map as Map
@@ -41,6 +44,13 @@ initContentStore = do
dbPath <- getContentStorePath
createDirectoryIfMissing True (takeDirectory dbPath)
conn <- open dbPath
+ setupDatabase conn
+ return conn
+
+-- | Initialise a database connection (file-backed or in-memory).
+-- This is factored out so tests can reuse it with ":memory:".
+setupDatabase :: Connection -> IO ()
+setupDatabase conn = do
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
\hash TEXT PRIMARY KEY, \
\names TEXT, \
@@ -52,12 +62,24 @@ initContentStore = do
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
\hash TEXT PRIMARY KEY, \
\node_data BLOB NOT NULL)"
- return conn
+ -- Seed canonical Leaf node payload (0x00)
+ putMerkleNode conn NLeaf
+
+-- | Create an in-memory ContentStore connection (for tests).
+newContentStore :: IO Connection
+newContentStore = do
+ conn <- open ":memory:"
+ setupDatabase conn
+ return conn
getContentStorePath :: IO FilePath
getContentStorePath = do
- dataDir <- getXdgDirectory XdgData "tricu"
- return $ dataDir </> "content-store.db"
+ maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
+ case maybeLocalPath of
+ Just p -> return p
+ Nothing -> do
+ dataDir <- getXdgDirectory XdgData "tricu"
+ return $ dataDir </> "content-store.db"
@@ -95,13 +117,11 @@ storeTerm conn newNamesStrList term = do
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
-- Recursively loads nodes and rebuilds the T structure.
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
-loadTree conn h
- | h == nodeHash NLeaf = return (Just Leaf) -- NLeaf is implicit, not stored
- | otherwise = do
- maybeNode <- getNodeMerkle conn h
- case maybeNode of
- Nothing -> return Nothing
- Just node -> Just <$> buildTree node
+loadTree conn h = do
+ maybeNode <- getNodeMerkle conn h
+ case maybeNode of
+ Nothing -> return Nothing
+ Just node -> Just <$> buildTree node
where
buildTree :: Node -> IO T
buildTree NLeaf = return Leaf
@@ -116,7 +136,9 @@ loadTree conn h
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
-- Returns the hash of the root node.
storeMerkleNodes :: Connection -> T -> IO MerkleHash
-storeMerkleNodes _ Leaf = return $ nodeHash NLeaf
+storeMerkleNodes conn Leaf = do
+ putMerkleNode conn NLeaf
+ return $ nodeHash NLeaf
storeMerkleNodes conn (Stem t) = do
childHash <- storeMerkleNodes conn t
let thisNode = NStem childHash
@@ -252,3 +274,36 @@ queryMaybeOne conn qry params = do
case results of
[row] -> return $ Just row
_ -> return Nothing
+
+-- | Resolve a user-supplied identifier (full/prefix hash, term name) to
+-- a single term hash and the list of names bound to it. Dies on
+-- ambiguity or missing term (matching the CLI @export@ semantics).
+resolveExportTarget :: Connection -> String -> IO (Text, [Text])
+resolveExportTarget conn input = do
+ let raw = T.pack $ dropWhile (== '#') input
+ byName <- query conn
+ "SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
+ (raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
+ case byName of
+ [Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
+ (_:_) -> die $ "Ambiguous term name: " ++ input
+ [] -> do
+ byHash <- query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
+ (Only (raw <> T.pack "%")) :: IO [Only T.Text]
+ case byHash of
+ [Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
+ [] -> if looksLikeHash raw
+ then return (raw, [])
+ else die $ "No term found matching: " ++ input
+ _ -> die $ "Ambiguous hash prefix: " ++ input
+
+namesForHash :: Connection -> Text -> IO [Text]
+namesForHash conn h = do
+ stored <- hashToTerm conn h
+ return $ maybe [] (parseNameList . termNames) stored
+
+-- | Return 'True' when @t@ looks like a full or partial SHA-256 hex hash.
+looksLikeHash :: Text -> Bool
+looksLikeHash t =
+ let len = T.length t
+ in len >= 16 && len <= 64 && T.all isHexDigit t
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -1,18 +1,30 @@
-module FileEval where
-
-import Eval
+module FileEval
+ ( preprocessFile
+ , evaluateFile
+ , evaluateFileWithContext
+ , evaluateFileResult
+ , compileFile
+ ) where
+
+import Eval (evalTricu)
import Lexer
import Parser
import Research
+import ContentStore (initContentStore, storeTerm, hashTerm)
+import Wire (exportNamedBundle)
import Control.Monad ()
import Data.List (partition)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
+import System.Environment (setEnv)
import System.FilePath (takeDirectory, normalise, (</>))
-import System.IO ()
+import System.Exit (die)
+import Database.SQLite.Simple (close)
+import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.Set as Set
+import qualified Data.Text as T
extractMain :: Env -> Either String T
extractMain env =
@@ -96,9 +108,6 @@ makeRelativeTo f i =
let d = takeDirectory f
in normalise $ d </> i
-nsDefinitions :: String -> [TricuAST] -> [TricuAST]
-nsDefinitions moduleName = map (nsDefinition moduleName)
-
nsDefinition :: String -> TricuAST -> TricuAST
nsDefinition "" def = def
nsDefinition moduleName (SDef name args body)
@@ -152,3 +161,26 @@ isPrefixed name = '.' `elem` name
nsVariable :: String -> String -> String
nsVariable "" name = name
nsVariable moduleName name = moduleName ++ "." ++ name
+
+-- | Compile a tricu source file to a standalone Arborix bundle.
+-- Uses a temp content store so it does not collide with the global one.
+compileFile :: FilePath -> FilePath -> Maybe T.Text -> IO ()
+compileFile inputPath outputPath maybeExportName = do
+ -- Evaluate the file to get the full environment
+ env <- evaluateFile inputPath
+ -- Look up the export name: prefer explicit, then fall back to "main"
+ let name = fromMaybe "main" (T.unpack <$> maybeExportName)
+ case Map.lookup name env of
+ Nothing -> die $ "No definition '" ++ name ++ "' found in " ++ inputPath
+ Just term -> do
+ -- Create a temp content store
+ setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
+ conn <- initContentStore
+ -- Store the term in the temp store
+ _ <- storeTerm conn [name] term
+ -- Export the bundle (exportNamedBundle returns already-encoded bytes)
+ bundleData <- exportNamedBundle conn [(T.pack name, hashTerm term)]
+ BL.writeFile outputPath (BL.fromStrict bundleData)
+ close conn
+ putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
+ putStrLn $ " export: " ++ name
diff --git a/src/Main.hs b/src/Main.hs
@@ -1,25 +1,37 @@
module Main where
-import ContentStore ()
+import ContentStore (initContentStore, loadEnvironment, resolveExportTarget)
+import Server (runServer)
import Eval (evalTricu, mainResult, result)
import FileEval
import Parser (parseTricu)
import REPL
import Research
+import Wire
import Control.Monad (foldM)
-import Control.Monad.IO.Class ()
+import Data.Text (Text, unpack)
+import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_tricu (version)
import System.Console.CmdArgs
+import System.Environment (lookupEnv)
+import System.IO (hPutStrLn, stderr)
import Text.Megaparsec ()
+import qualified Data.ByteString.Lazy as BL
+import Database.SQLite.Simple (close)
+
import qualified Data.Map as Map
data TricuArgs
= Repl
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
| TDecode { file :: [FilePath] }
+ | Compile { inputFile :: FilePath, outFile :: FilePath, exportNameOpt :: String }
+ | Export { hash :: String, exportNameOpt :: String, outFile :: FilePath }
+ | Import { inFile :: FilePath }
+ | Serve { host :: String, port :: Int }
deriving (Show, Data, Typeable)
replMode :: TricuArgs
@@ -53,10 +65,53 @@ decodeMode = TDecode
&= explicit
&= name "decode"
+exportMode :: TricuArgs
+exportMode = Export
+ { hash = def &= help "Full/prefix hash or stored term name to export."
+ &= name "h" &= typ "HASH_OR_NAME"
+ , exportNameOpt = def &= help "Export name to place in the bundle manifest. Defaults to the stored term name when exporting by name; otherwise defaults to root."
+ &= name "n" &= typ "NAME"
+ , outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
+ }
+ &= help "Export a Merkle bundle from the content store."
+ &= explicit
+ &= name "export"
+
+importMode :: TricuArgs
+importMode = Import
+ { inFile = def &= help "Path to the bundle file to import."
+ &= name "f" &= typ "FILE"
+ }
+ &= help "Import a Merkle bundle into the content store."
+ &= explicit
+ &= name "import"
+
+compileMode :: TricuArgs
+compileMode = Compile
+ { inputFile = def &= help "Path to the tricu source file (.tri) to compile."
+ &= name "f" &= typ "FILE"
+ , outFile = def &= help "Output bundle file path (.tri.bundle)."
+ &= name "o" &= typ "FILE"
+ , exportNameOpt = def &= help "Definition name to use as the bundle root. Defaults to 'main'."
+ &= name "x" &= typ "NAME"
+ }
+ &= help "Compile a tricu source file into a standalone Arborix portable bundle."
+ &= explicit
+ &= name "compile"
+
+serveMode :: TricuArgs
+serveMode = Serve
+ { host = "127.0.0.1" &= help "Host to bind the server to." &= name "h" &= typ "HOST"
+ , port = 8787 &= help "HTTP port to listen on." &= name "p" &= typ "PORT"
+ }
+ &= help "Start a read-only HTTP server for exporting Arborix bundles."
+ &= explicit
+ &= name "server"
+
main :: IO ()
main = do
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
- cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
+ cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary versionStr
@@ -67,10 +122,26 @@ main = do
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
Evaluate { file = filePaths, form = outputForm } -> do
+ maybeDbPath <- lookupEnv "TRICU_DB_PATH"
evalResult <- case filePaths of
- [] -> runTricuT <$> getContents
- (filePath:restFilePaths) -> do
- initialEnv <- evaluateFile filePath
+ [] -> do
+ initialEnv <- case maybeDbPath of
+ Just _ -> do
+ conn <- initContentStore
+ env <- loadEnvironment conn
+ close conn
+ return env
+ Nothing -> return Map.empty
+ input <- getContents
+ pure $ runTricuTEnv initialEnv input
+ (_:restFilePaths) -> do
+ initialEnv <- case maybeDbPath of
+ Just _ -> do
+ conn <- initContentStore
+ env <- loadEnvironment conn
+ close conn
+ return env
+ Nothing -> return Map.empty
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
pure $ mainResult finalEnv
let fRes = formatT outputForm evalResult
@@ -80,6 +151,30 @@ main = do
[] -> getContents
(filePath:_) -> readFile filePath
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
+ Export { hash = hashStr, exportNameOpt = exportNameArg, outFile = outFilePath } -> do
+ conn <- initContentStore
+ (resolvedHash, storedNames) <- resolveExportTarget conn hashStr
+ expName <- chooseExportName exportNameArg hashStr storedNames
+ bundleData <- exportNamedBundle conn [(expName, resolvedHash)]
+ BL.writeFile outFilePath (BL.fromStrict bundleData)
+ putStrLn $ "Exported bundle export " ++ unpack expName ++ " -> " ++ unpack resolvedHash ++ " to " ++ outFilePath
+ close conn
+ Import { inFile = importFile } -> do
+ conn <- initContentStore
+ bundleData <- BL.readFile importFile
+ roots <- importBundle conn (BL.toStrict bundleData)
+ putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
+ mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
+ close conn
+ Compile { inputFile = compileInputFile, outFile = compileOutFile, exportNameOpt = exportNameArg } ->
+ let bundleExportName = if null exportNameArg then Nothing else Just (T.pack exportNameArg)
+ in compileFile compileInputFile compileOutFile bundleExportName
+ Serve { host = hostStr, port = portNum } -> do
+ putStrLn $ "Starting Arborix bundle server on " ++ hostStr ++ ":" ++ show portNum
+ putStrLn $ " GET /bundle/hash/:hash — primary endpoint"
+ putStrLn $ " GET /bundle/name/:name — convenience endpoint"
+ putStrLn $ " Content-Type: application/vnd.arborix.bundle"
+ runServer hostStr portNum
runTricu :: String -> String
runTricu = formatT TreeCalculus . runTricuT
@@ -124,3 +219,21 @@ runTricuEnvWithEnv env input =
finalEnv = evalTricu env asts
res = result finalEnv
in (finalEnv, formatT TreeCalculus res)
+
+chooseExportName :: String -> String -> [Text] -> IO Text
+chooseExportName explicitName input storedNames
+ | not (null explicitName) = return $ T.pack explicitName
+ | Just firstName <- firstNonEmpty storedNames = return firstName
+ | otherwise = do
+ hPutStrLn stderr $
+ "No stored name found for export target " ++ input ++ "; using export name 'root'. "
+ ++ "Use export -n NAME to preserve a semantic name."
+ return "root"
+
+firstNonEmpty :: [Text] -> Maybe Text
+firstNonEmpty = go
+ where
+ go [] = Nothing
+ go (x:xs)
+ | T.null x = go xs
+ | otherwise = Just x
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -6,6 +6,7 @@ import FileEval
import Lexer ()
import Parser
import Research
+import Wire
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
import Control.Exception (SomeException, catch, displayException)
@@ -17,6 +18,8 @@ import Control.Monad.Trans.Class ()
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.ByteString ()
import Data.Char (isSpace)
+
+import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (dropWhileEnd, isPrefixOf, find)
import Data.Maybe (isJust, fromJust)
@@ -73,6 +76,8 @@ repl = do
, "!versions"
, "!select"
, "!tag"
+ , "!export"
+ , "!bundleimport"
]
loop :: REPLState -> InputT IO ()
@@ -103,6 +108,8 @@ repl = do
outputStrLn " !versions - Show all versions of a term by name"
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
outputStrLn " !tag - Add or update a tag for a term by hash or name"
+ outputStrLn " !export - Export a term bundle to file (hash, file)"
+ outputStrLn " !bundleimport- Import a bundle file into the content store"
loop state
| strip s == "!output" -> handleOutput state
| strip s == "!definitions" -> handleDefinitions state
@@ -112,6 +119,8 @@ repl = do
| "!versions" `isPrefixOf` strip s -> handleVersions state
| "!select" `isPrefixOf` strip s -> handleSelect state
| "!tag" `isPrefixOf` strip s -> handleTag state
+ | "!export" `isPrefixOf` strip s -> handleExport state
+ | "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
| take 2 s == "--" -> loop state
| otherwise -> do
evalResult <- liftIO $ catch
@@ -438,6 +447,74 @@ repl = do
then do printError $ "No versions found for term name: " ++ ident; return Nothing
else return $ Just $ (\(h,_,_) -> h) $ head versions
+ handleExport :: REPLState -> InputT IO ()
+ handleExport state = do
+ let fset = setComplete completeFilename defaultSettings
+ hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
+ case hashInput of
+ Nothing -> loop state
+ Just hashStr -> do
+ fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
+ case fileInput of
+ Nothing -> loop state
+ Just outFile -> case replContentStore state of
+ Nothing -> do
+ liftIO $ printError "Content store not initialized"
+ loop state
+ Just conn -> do
+ let cleanHash = strip hashStr
+ hash <- liftIO $ do
+ let h = T.pack cleanHash
+ if '#' `T.elem` h
+ then return h
+ else do
+ results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
+ (Only (h <> "%")) :: IO [Only T.Text]
+ case results of
+ [Only fullHash] -> return fullHash
+ [] -> do
+ results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
+ (Only (h <> "%")) :: IO [Only T.Text]
+ case results2 of
+ [Only fullHash] -> return fullHash
+ _ -> do
+ printError $ "No term found matching: " ++ cleanHash
+ return h
+ _ -> do
+ printError $ "Ambiguous match for: " ++ cleanHash
+ return h
+ bundleData <- liftIO $ exportBundle conn [hash]
+ liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
+ liftIO $ do
+ printSuccess $ "Exported bundle with root "
+ displayColoredHash hash
+ putStrLn $ " to " ++ outFile
+ loop state
+
+ handleBundleImport :: REPLState -> InputT IO ()
+ handleBundleImport state = do
+ let fset = setComplete completeFilename defaultSettings
+ fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
+ case fileInput of
+ Nothing -> loop state
+ Just inFile -> case replContentStore state of
+ Nothing -> do
+ liftIO $ printError "Content store not initialized"
+ loop state
+ Just conn -> do
+ exists <- liftIO $ doesFileExist inFile
+ if not exists
+ then do
+ liftIO $ printError $ "File not found: " ++ inFile
+ loop state
+ else do
+ bundleData <- liftIO $ BL.readFile inFile
+ roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
+ liftIO $ do
+ printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
+ mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
+ loop state
+
interruptHandler :: REPLState -> Interrupt -> InputT IO ()
interruptHandler state _ = do
liftIO $ do
diff --git a/src/Server.hs b/src/Server.hs
@@ -0,0 +1,176 @@
+module Server
+ ( runServer
+ ) where
+
+import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
+ parseNameList, StoredTerm(..), termHash)
+import Database.SQLite.Simple (close)
+import Wire (exportNamedBundle)
+
+import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
+import Network.Wai
+import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
+
+import Data.String (fromString)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Char (isHexDigit)
+import Data.ByteString.Lazy (fromStrict)
+
+import qualified Data.Text as T
+
+-- | Start an HTTP server that serves Arborix bundles from the
+-- local content store.
+--
+-- This is a read-only export surface. Clients fetch bundle bytes
+-- and independently inspect / verify / run them. The server does
+-- not execute bundles.
+--
+-- Bind host defaults to @127.0.0.1@.
+--
+-- Endpoints
+-- ---------
+-- GET /health — 200 "ok"
+-- GET /bundle/name/:name — export by stored term name
+-- GET /bundle/hash/:hash — export by full Merkle hash
+-- GET /terms — plain-text listing (debug)
+--
+runServer :: String -> Int -> IO ()
+runServer hostStr port =
+ runSettings settings app
+ where
+ settings = setPort port $ setHost (fromString hostStr) defaultSettings
+
+-- | WAI application backed by the content store.
+-- Uses the same database path as @eval@ mode (env var
+-- @TRICU_DB_PATH@ or the default location).
+app :: Application
+app request respond = case (requestMethod request, pathInfo request) of
+ ("GET", ["health"]) ->
+ respond $ healthResponse
+
+ ("GET", ["bundle", "name", nameText]) -> do
+ body <- nameHandler nameText
+ respond body
+
+ ("GET", ["bundle", "hash", hashText]) -> do
+ body <- hashHandler hashText
+ respond body
+
+ ("GET", ["terms"]) -> do
+ body <- termsResponse
+ respond body
+
+ ("POST", _) ->
+ respond $ responseLBS status405 [] "Method not allowed"
+
+ ("PUT", _) ->
+ respond $ responseLBS status405 [] "Method not allowed"
+
+ ("DELETE", _) ->
+ respond $ responseLBS status405 [] "Method not allowed"
+
+ _ ->
+ respond $ responseLBS status404 [] "not found"
+
+healthResponse :: Response
+healthResponse = responseLBS status200 [] "ok"
+
+-- | GET /bundle/name/:name
+-- Resolve a stored term name, export it as an Arborix bundle,
+-- and return the raw bundle bytes.
+--
+-- Sets @Content-Type@ and @X-Arborix-Root-Hash@ headers.
+-- Returns 404 when the name does not resolve to any stored term.
+nameHandler :: Text -> IO Response
+nameHandler nameText = do
+ conn <- initContentStore
+ stored <- nameToTerm conn nameText
+ case stored of
+ Nothing -> do
+ close conn
+ return $ textResponse status404 ("not found: " <> nameText)
+ Just term' -> do
+ let th = termHash term'
+ namedHashes = [(firstOrRoot (termNames term'), th)]
+ bundleData <- exportNamedBundle conn namedHashes
+ let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
+ close conn
+ return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
+
+-- | GET /bundle/hash/:hash
+-- Resolve a full Merkle hash and export the root as an Arborix
+-- bundle.
+--
+-- - Malformed hash (non-hex or < 16 chars): 400
+-- - Well-formed but absent: 404
+-- - Present: 200 with bundle bytes
+hashHandler :: Text -> IO Response
+hashHandler hashText =
+ let raw = T.pack (dropWhile (== '#') (T.unpack hashText))
+ in if not (T.all isHexDigit raw) || T.length raw < 16
+ then return $ responseLBS status400 [] "400 Bad Request: invalid hash"
+ else do
+ conn <- initContentStore
+ stored <- hashToTerm conn raw
+ case stored of
+ Nothing -> do
+ close conn
+ return $ textResponse status404 ("not found: " <> hashText)
+ Just term' -> do
+ let th = termHash term'
+ namedHashes' = [(firstOrRoot (termNames term'), th)]
+ bundleData <- exportNamedBundle conn namedHashes'
+ close conn
+ return $ responseLBS status200
+ (bundleHeaders th "attachment; filename=hash.bundle")
+ (fromStrict bundleData)
+
+-- | GET /terms
+-- Plain-text listing of all stored terms (debugging only).
+termsResponse :: IO Response
+termsResponse = do
+ conn <- initContentStore
+ terms <- listStoredTerms conn
+ close conn
+ let lines' = [ names <> " " <> hash <> " " <> T.pack (show created)
+ | term <- terms
+ , let names = termNames term
+ , let hash = termHash term
+ , let created = termCreatedAt term ]
+ return $ responseLBS status200
+ [ (hContentType, encodeUtf8 "text/plain; charset=utf-8")
+ ]
+ (fromStrict $ encodeUtf8 $ T.unlines lines')
+
+textResponse :: Status -> Text -> Response
+textResponse status body =
+ responseLBS status
+ [ (hContentType, encodeUtf8 "text/plain; charset=utf-8") ]
+ (fromStrict $ encodeUtf8 body)
+
+bundleHeaders :: Text -> Text -> [Header]
+bundleHeaders root cd =
+ [ (hContentType, encodeUtf8 "application/vnd.arborix.bundle")
+ , ("X-Arborix-Root-Hash", encodeUtf8 root)
+ , ("Content-Disposition", encodeUtf8 cd)
+ ]
+
+-- | Pick the first stored name, falling back to "root" when names are empty.
+firstOrRoot :: Text -> Text
+firstOrRoot names =
+ case parseNameList names of
+ [] -> "root"
+ (x:_) -> x
+
+-- | Sanitise a string to a safe filename prefix.
+safeFileName :: String -> String
+safeFileName = map go
+ where
+ go c
+ | c >= 'a' && c <= 'z' = c
+ | c >= 'A' && c <= 'Z' = c
+ | c >= '0' && c <= '9' = c
+ | c == '-' = c
+ | c == '_' = c
+ | otherwise = '_'
diff --git a/src/Wire.hs b/src/Wire.hs
@@ -0,0 +1,809 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Wire
+ ( Bundle (..)
+ , BundleManifest (..)
+ , TreeSpec (..)
+ , NodeHashSpec (..)
+ , RuntimeSpec (..)
+ , BundleRoot (..)
+ , BundleExport (..)
+ , BundleMetadata (..)
+ , ClosureMode (..)
+ , encodeBundle
+ , decodeBundle
+ , verifyBundle
+ , collectReachableNodes
+ , exportBundle
+ , exportNamedBundle
+ , importBundle
+ ) where
+
+import ContentStore (getNodeMerkle, loadTree, putMerkleNode, storeTerm)
+import Research
+
+import Control.Exception (SomeException, evaluate, try)
+import Control.Monad (foldM, unless, when)
+import Crypto.Hash (Digest, SHA256, hash)
+import Data.Aeson ( FromJSON (..)
+ , ToJSON (..)
+ , Value (String)
+ , eitherDecodeStrict'
+ , encode
+ , object
+ , withObject
+ , (.:)
+ , (.:?)
+ , (.!=)
+ , (.=)
+ )
+import Data.Bits ((.&.), (.|.), shiftL, shiftR)
+import Data.ByteArray (convert)
+import Data.ByteString (ByteString)
+import Data.Foldable (traverse_)
+import Data.Map (Map)
+import Data.Text (Text, unpack)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Word (Word16, Word32, Word64)
+import Database.SQLite.Simple (Connection)
+import GHC.Generics (Generic)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+
+-- | Portable bundle major/minor version supported by this module.
+bundleMajorVersion :: Word16
+bundleMajorVersion = 1
+
+bundleMinorVersion :: Word16
+bundleMinorVersion = 0
+
+-- | Header magic for the portable executable-object container.
+bundleMagic :: ByteString
+bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00] -- "ARBORIX\0"
+
+headerLength :: Int
+headerLength = 32
+
+sectionEntryLength :: Int
+sectionEntryLength = 60
+
+sectionManifest, sectionNodes :: Word32
+sectionManifest = 1
+sectionNodes = 2
+
+flagCritical :: Word16
+flagCritical = 0x0001
+
+compressionNone, digestSha256 :: Word16
+compressionNone = 0
+digestSha256 = 1
+
+-- | Closure declaration. V1 only accepts complete bundles for import.
+data ClosureMode = ClosureComplete | ClosurePartial
+ deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON ClosureMode where
+ toJSON ClosureComplete = String "complete"
+ toJSON ClosurePartial = String "partial"
+
+instance FromJSON ClosureMode where
+ parseJSON (String "complete") = pure ClosureComplete
+ parseJSON (String "partial") = pure ClosurePartial
+ parseJSON _ = fail "closure must be \"complete\" or \"partial\""
+
+data NodeHashSpec = NodeHashSpec
+ { nodeHashAlgorithm :: Text
+ , nodeHashDomain :: Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON NodeHashSpec where
+ toJSON s = object
+ [ "algorithm" .= nodeHashAlgorithm s
+ , "domain" .= nodeHashDomain s
+ ]
+
+instance FromJSON NodeHashSpec where
+ parseJSON = withObject "NodeHashSpec" $ \o -> NodeHashSpec
+ <$> o .: "algorithm"
+ <*> o .: "domain"
+
+data TreeSpec = TreeSpec
+ { treeCalculus :: Text
+ , treeNodeHash :: NodeHashSpec
+ , treeNodePayload :: Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON TreeSpec where
+ toJSON s = object
+ [ "calculus" .= treeCalculus s
+ , "nodeHash" .= treeNodeHash s
+ , "nodePayload" .= treeNodePayload s
+ ]
+
+instance FromJSON TreeSpec where
+ parseJSON = withObject "TreeSpec" $ \o -> TreeSpec
+ <$> o .: "calculus"
+ <*> o .: "nodeHash"
+ <*> o .: "nodePayload"
+
+data RuntimeSpec = RuntimeSpec
+ { runtimeSemantics :: Text
+ , runtimeEvaluation :: Text
+ , runtimeAbi :: Text
+ , runtimeCapabilities :: [Text]
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON RuntimeSpec where
+ toJSON s = object
+ [ "semantics" .= runtimeSemantics s
+ , "evaluation" .= runtimeEvaluation s
+ , "abi" .= runtimeAbi s
+ , "capabilities" .= runtimeCapabilities s
+ ]
+
+instance FromJSON RuntimeSpec where
+ parseJSON = withObject "RuntimeSpec" $ \o -> RuntimeSpec
+ <$> o .: "semantics"
+ <*> o .: "evaluation"
+ <*> o .: "abi"
+ <*> o .:? "capabilities" .!= []
+
+data BundleRoot = BundleRoot
+ { rootHash :: MerkleHash
+ , rootRole :: Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON BundleRoot where
+ toJSON r = object
+ [ "hash" .= rootHash r
+ , "role" .= rootRole r
+ ]
+
+instance FromJSON BundleRoot where
+ parseJSON = withObject "BundleRoot" $ \o -> BundleRoot
+ <$> o .: "hash"
+ <*> o .:? "role" .!= "root"
+
+data BundleExport = BundleExport
+ { exportName :: Text
+ , exportRoot :: MerkleHash
+ , exportKind :: Text
+ , exportAbi :: Text
+ , exportInput :: Maybe Text
+ , exportOutput :: Maybe Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON BundleExport where
+ toJSON e = object
+ [ "name" .= exportName e
+ , "root" .= exportRoot e
+ , "kind" .= exportKind e
+ , "abi" .= exportAbi e
+ , "input" .= exportInput e
+ , "output" .= exportOutput e
+ ]
+
+instance FromJSON BundleExport where
+ parseJSON = withObject "BundleExport" $ \o -> BundleExport
+ <$> o .: "name"
+ <*> o .: "root"
+ <*> o .:? "kind" .!= "term"
+ <*> o .:? "abi" .!= "arborix.abi.tree.v1"
+ <*> o .:? "input"
+ <*> o .:? "output"
+
+data BundleMetadata = BundleMetadata
+ { metadataPackage :: Maybe Text
+ , metadataVersion :: Maybe Text
+ , metadataDescription :: Maybe Text
+ , metadataLicense :: Maybe Text
+ , metadataCreatedBy :: Maybe Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance ToJSON BundleMetadata where
+ toJSON m = object
+ [ "package" .= metadataPackage m
+ , "version" .= metadataVersion m
+ , "description" .= metadataDescription m
+ , "license" .= metadataLicense m
+ , "createdBy" .= metadataCreatedBy m
+ ]
+
+instance FromJSON BundleMetadata where
+ parseJSON = withObject "BundleMetadata" $ \o -> BundleMetadata
+ <$> o .:? "package"
+ <*> o .:? "version"
+ <*> o .:? "description"
+ <*> o .:? "license"
+ <*> o .:? "createdBy"
+
+data BundleManifest = BundleManifest
+ { manifestSchema :: Text
+ , manifestBundleType :: Text
+ , manifestTree :: TreeSpec
+ , manifestRuntime :: RuntimeSpec
+ , manifestClosure :: ClosureMode
+ , manifestRoots :: [BundleRoot]
+ , manifestExports :: [BundleExport]
+ , manifestImports :: [Value]
+ , manifestSections :: Value
+ , manifestMetadata :: BundleMetadata
+ } deriving (Show, Eq, Generic)
+
+instance ToJSON BundleManifest where
+ toJSON m = object
+ [ "schema" .= manifestSchema m
+ , "bundleType" .= manifestBundleType m
+ , "tree" .= manifestTree m
+ , "runtime" .= manifestRuntime m
+ , "closure" .= manifestClosure m
+ , "roots" .= manifestRoots m
+ , "exports" .= manifestExports m
+ , "imports" .= manifestImports m
+ , "sections" .= manifestSections m
+ , "metadata" .= manifestMetadata m
+ ]
+
+instance FromJSON BundleManifest where
+ parseJSON = withObject "BundleManifest" $ \o -> BundleManifest
+ <$> o .: "schema"
+ <*> o .: "bundleType"
+ <*> o .: "tree"
+ <*> o .: "runtime"
+ <*> o .: "closure"
+ <*> o .: "roots"
+ <*> o .: "exports"
+ <*> o .:? "imports" .!= []
+ <*> o .:? "sections" .!= object []
+ <*> o .:? "metadata" .!= BundleMetadata Nothing Nothing Nothing Nothing Nothing
+
+-- | Portable executable-object bundle.
+--
+-- Merkle node payloads remain the language-neutral executable core:
+-- Leaf = 0x00; Stem = 0x01 || child_hash; Fork = 0x02 || left_hash || right_hash.
+-- Names, exports, runtime metadata, and package metadata live in the manifest layer.
+data Bundle = Bundle
+ { bundleVersion :: Word16
+ , bundleRoots :: [MerkleHash]
+ , bundleNodes :: Map MerkleHash ByteString
+ , bundleManifest :: BundleManifest
+ , bundleManifestBytes :: ByteString
+ } deriving (Show, Eq)
+
+-- | Encode a Bundle to portable Bundle v1 bytes.
+encodeBundle :: Bundle -> ByteString
+encodeBundle bundle =
+ let nodeSection = encodeNodeSection (bundleNodes bundle)
+ manifestBytes = if BS.null (bundleManifestBytes bundle)
+ then BL.toStrict (encode (bundleManifest bundle))
+ else bundleManifestBytes bundle
+ sectionCount = 2
+ dirOffset = fromIntegral headerLength
+ sectionDirLength = sectionCount * sectionEntryLength
+ manifestOffset = fromIntegral (headerLength + sectionDirLength)
+ nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes)
+ manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone
+ manifestOffset (fromIntegral $ BS.length manifestBytes) manifestBytes
+ nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone
+ nodesOffset (fromIntegral $ BS.length nodeSection) nodeSection
+ header = encodeHeader bundleMajorVersion bundleMinorVersion
+ (fromIntegral sectionCount) 0 dirOffset
+ in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection
+
+-- | Decode portable Bundle v1 bytes.
+decodeBundle :: ByteString -> Either String Bundle
+decodeBundle bs
+ | BS.take (BS.length bundleMagic) bs == bundleMagic = decodePortableBundle bs
+ | otherwise = Left "invalid magic"
+
+-- ---------------------------------------------------------------------------
+-- Portable container encoding / decoding
+-- ---------------------------------------------------------------------------
+
+data SectionEntry = SectionEntry
+ { seType :: Word32
+ , seVersion :: Word16
+ , seFlags :: Word16
+ , seCompression :: Word16
+ , seDigestAlgorithm :: Word16
+ , seOffset :: Word64
+ , seLength :: Word64
+ , seDigest :: ByteString
+ } deriving (Show, Eq)
+
+encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString
+encodeHeader major minor sectionCount flags dirOffset =
+ bundleMagic
+ <> encode16 major
+ <> encode16 minor
+ <> encode32 sectionCount
+ <> encode64 flags
+ <> encode64 dirOffset
+
+encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString -> ByteString
+encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes sectionBytes =
+ encode32 sectionType
+ <> encode16 sectionVersion
+ <> encode16 sectionFlags
+ <> encode16 compression
+ <> encode16 digestSha256
+ <> encode64 offset
+ <> encode64 lengthBytes
+ <> sha256 sectionBytes
+
+decodePortableBundle :: ByteString -> Either String Bundle
+decodePortableBundle bs = do
+ (major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs
+ when (major /= bundleMajorVersion) $
+ Left $ "unsupported bundle major version: " ++ show major
+ let dirStart = fromIntegral dirOffset
+ dirBytes = fromIntegral sectionCount * sectionEntryLength
+ when (BS.length bs < dirStart + dirBytes) $
+ Left "bundle truncated in section directory"
+ entries <- decodeSectionEntries sectionCount (BS.take dirBytes $ BS.drop dirStart bs)
+ traverse_ rejectUnknownCritical entries
+ manifestEntry <- requireSection sectionManifest entries
+ nodesEntry <- requireSection sectionNodes entries
+ manifestBytes <- readAndVerifySection bs manifestEntry
+ nodesBytes <- readAndVerifySection bs nodesEntry
+ manifest <- case eitherDecodeStrict' manifestBytes of
+ Left err -> Left $ "invalid manifest JSON: " ++ err
+ Right m -> Right m
+ nodes <- decodeNodeSection nodesBytes
+ let roots = map rootHash (manifestRoots manifest)
+ return Bundle
+ { bundleVersion = major * 1000 + minor
+ , bundleRoots = roots
+ , bundleNodes = nodes
+ , bundleManifest = manifest
+ , bundleManifestBytes = manifestBytes
+ }
+
+rejectUnknownCritical :: SectionEntry -> Either String ()
+rejectUnknownCritical entry =
+ let known = seType entry `elem` [sectionManifest, sectionNodes]
+ critical = seFlags entry .&. flagCritical /= 0
+ in when (critical && not known) $
+ Left $ "unknown critical section type: " ++ show (seType entry)
+
+requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry
+requireSection sectionType entries =
+ case filter ((== sectionType) . seType) entries of
+ [entry] -> Right entry
+ [] -> Left $ "missing required section type: " ++ show sectionType
+ _ -> Left $ "duplicate section type: " ++ show sectionType
+
+readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString
+readAndVerifySection bs entry = do
+ when (seCompression entry /= compressionNone) $
+ Left $ "unsupported compression codec in section " ++ show (seType entry)
+ when (seDigestAlgorithm entry /= digestSha256) $
+ Left $ "unsupported digest algorithm in section " ++ show (seType entry)
+ let offset = fromIntegral (seOffset entry)
+ len = fromIntegral (seLength entry)
+ when (offset < 0 || len < 0 || BS.length bs < offset + len) $
+ Left $ "section extends beyond bundle end: " ++ show (seType entry)
+ let sectionBytes = BS.take len $ BS.drop offset bs
+ when (sha256 sectionBytes /= seDigest entry) $
+ Left $ "section digest mismatch: " ++ show (seType entry)
+ Right sectionBytes
+
+decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64)
+decodePortableHeader bs
+ | BS.length bs < headerLength = Left "bundle too short for header"
+ | BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic"
+ | otherwise = do
+ (major, r1) <- decode16be "major_version" (BS.drop 8 bs)
+ (minor, r2) <- decode16be "minor_version" r1
+ (sectionCount, r3) <- decode32be "section_count" r2
+ (flags, r4) <- decode64be "flags" r3
+ (dirOffset, _) <- decode64be "directory_offset" r4
+ Right (major, minor, sectionCount, flags, dirOffset)
+
+decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry]
+decodeSectionEntries count bytes = reverse <$> go count bytes []
+ where
+ go 0 _ acc = Right acc
+ go n bs acc = do
+ when (BS.length bs < sectionEntryLength) $
+ Left "section directory truncated"
+ (sectionType, r1) <- decode32be "section_type" bs
+ (sectionVersion, r2) <- decode16be "section_version" r1
+ (sectionFlags, r3) <- decode16be "section_flags" r2
+ (compression, r4) <- decode16be "compression_codec" r3
+ (digAlg, r5) <- decode16be "digest_algorithm" r4
+ (offset, r6) <- decode64be "section_offset" r5
+ (len, r7) <- decode64be "section_length" r6
+ let (dig, rest) = BS.splitAt 32 r7
+ when (BS.length dig /= 32) $ Left "section digest truncated"
+ let entry = SectionEntry sectionType sectionVersion sectionFlags compression digAlg offset len dig
+ go (n - 1) rest (entry : acc)
+
+-- ---------------------------------------------------------------------------
+-- Manifest construction
+-- ---------------------------------------------------------------------------
+
+defaultManifest :: [(Text, MerkleHash)] -> Int -> BundleManifest
+defaultManifest namedRoots nodeCount = BundleManifest
+ { manifestSchema = "arborix.bundle.manifest.v1"
+ , manifestBundleType = "tree-calculus-executable-object"
+ , manifestTree = TreeSpec
+ { treeCalculus = "tree-calculus.v1"
+ , treeNodeHash = NodeHashSpec
+ { nodeHashAlgorithm = "sha256"
+ , nodeHashDomain = "arborix.merkle.node.v1"
+ }
+ , treeNodePayload = "arborix.merkle.payload.v1"
+ }
+ , manifestRuntime = RuntimeSpec
+ { runtimeSemantics = "tree-calculus.v1"
+ , runtimeEvaluation = "normal-order"
+ , runtimeAbi = "arborix.abi.tree.v1"
+ , runtimeCapabilities = []
+ }
+ , manifestClosure = ClosureComplete
+ , manifestRoots = zipWith mkRoot [0 :: Int ..] (map snd namedRoots)
+ , manifestExports = map mkExport namedRoots
+ , manifestImports = []
+ , manifestSections = object
+ [ "nodes" .= object
+ [ "count" .= nodeCount
+ , "payload" .= ("arborix.merkle.payload.v1" :: Text)
+ ]
+ ]
+ , manifestMetadata = BundleMetadata
+ { metadataPackage = Nothing
+ , metadataVersion = Nothing
+ , metadataDescription = Nothing
+ , metadataLicense = Nothing
+ , metadataCreatedBy = Just "arborix"
+ }
+ }
+ where
+ mkRoot 0 h = BundleRoot h "default"
+ mkRoot _ h = BundleRoot h "root"
+ mkExport (name, h) = BundleExport
+ { exportName = name
+ , exportRoot = h
+ , exportKind = "term"
+ , exportAbi = "arborix.abi.tree.v1"
+ , exportInput = Nothing
+ , exportOutput = Nothing
+ }
+
+-- ---------------------------------------------------------------------------
+-- Node section encoding / decoding
+-- ---------------------------------------------------------------------------
+
+encodeNodeSection :: Map MerkleHash ByteString -> ByteString
+encodeNodeSection nodes =
+ encode64 (fromIntegral $ Map.size nodes)
+ <> mconcat (map nodeEntryToBinary $ Map.toAscList nodes)
+
+-- | Encode a single (hash, canonical-payload) node entry.
+nodeEntryToBinary :: (MerkleHash, ByteString) -> ByteString
+nodeEntryToBinary (h, payload) =
+ merkleHashToRaw h
+ <> encode32 (fromIntegral $ BS.length payload)
+ <> payload
+
+decodeNodeSection :: ByteString -> Either String (Map MerkleHash ByteString)
+decodeNodeSection bs = do
+ (nodeCount, rest) <- decode64be "node_count" bs
+ decodeNodeEntries nodeCount rest
+
+-- | Decode a sequence of node entries.
+decodeNodeEntries :: Word64 -> ByteString -> Either String (Map MerkleHash ByteString)
+decodeNodeEntries count bs = go count bs Map.empty
+ where
+ go 0 rest acc
+ | BS.null rest = Right acc
+ | otherwise = Left "trailing bytes after node section"
+ go n bytes acc
+ | BS.length bytes < 36 =
+ Left "not enough bytes for node entry header (hash + length)"
+ | otherwise = do
+ let (hashBytes, rest) = BS.splitAt 32 bytes
+ (plen, rest') <- decode32be "payload_len" rest
+ let payloadLen = fromIntegral plen
+ if BS.length rest' < payloadLen
+ then Left "payload extends beyond node section end"
+ else do
+ let (payload, after) = BS.splitAt payloadLen rest'
+ h = rawToMerkleHash hashBytes
+ when (Map.member h acc) $
+ Left $ "duplicate node entry: " ++ unpack h
+ go (n - 1) after (Map.insert h payload acc)
+
+
+
+-- ---------------------------------------------------------------------------
+-- Bundle verification
+-- ---------------------------------------------------------------------------
+
+verifyBundle :: Bundle -> Either String ()
+verifyBundle bundle
+ | bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle)
+ | Map.null (bundleNodes bundle) = Left "bundle has no nodes"
+verifyBundle bundle = do
+ verifyManifest (bundleManifest bundle)
+ let nodeMap = bundleNodes bundle
+ rootSet = Set.fromList (bundleRoots bundle)
+ manifestRootSet = Set.fromList (map rootHash $ manifestRoots $ bundleManifest bundle)
+ exportRoots = map exportRoot $ manifestExports $ bundleManifest bundle
+ unless (rootSet == manifestRootSet) $
+ Left "bundle root list does not match manifest roots"
+ traverse_ (requirePresent "root hash missing from bundle") (bundleRoots bundle)
+ traverse_ (requirePresent "export root hash missing from bundle") exportRoots
+ decoded <- traverse verifyNodePayload (Map.toList nodeMap)
+ traverse_ (verifyChildrenPresent nodeMap) decoded
+ verifyCompleteClosure nodeMap (bundleRoots bundle)
+ where
+ requirePresent label h =
+ unless (Map.member h (bundleNodes bundle)) $
+ Left $ label ++ ": " ++ unpack h
+
+verifyManifest :: BundleManifest -> Either String ()
+verifyManifest manifest = do
+ when (manifestSchema manifest /= "arborix.bundle.manifest.v1") $
+ Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest)
+ when (manifestBundleType manifest /= "tree-calculus-executable-object") $
+ Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest)
+ let treeSpec = manifestTree manifest
+ hashSpec = treeNodeHash treeSpec
+ runtimeSpec = manifestRuntime manifest
+ when (treeCalculus treeSpec /= "tree-calculus.v1") $
+ Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec)
+ when (nodeHashAlgorithm hashSpec /= "sha256") $
+ Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec)
+ when (nodeHashDomain hashSpec /= "arborix.merkle.node.v1") $
+ Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
+ when (treeNodePayload treeSpec /= "arborix.merkle.payload.v1") $
+ Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec)
+ when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $
+ Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec)
+ when (runtimeAbi runtimeSpec /= "arborix.abi.tree.v1") $
+ Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec)
+ unless (null $ runtimeCapabilities runtimeSpec) $
+ Left "host/runtime capabilities are not supported by bundle v1"
+ when (manifestClosure manifest /= ClosureComplete) $
+ Left "bundle v1 imports require closure = complete"
+ unless (null $ manifestImports manifest) $
+ Left "bundle v1 imports require an empty imports list"
+ when (null $ manifestRoots manifest) $
+ Left "manifest has no roots"
+ when (null $ manifestExports manifest) $
+ Left "manifest has no exports"
+ traverse_ verifyExport (manifestExports manifest)
+ where
+ verifyExport exported = do
+ when (T.null $ exportName exported) $
+ Left "manifest export has empty name"
+ when (T.null $ exportRoot exported) $
+ Left "manifest export has empty root"
+
+verifyNodePayload :: (MerkleHash, ByteString) -> Either String (MerkleHash, Node)
+verifyNodePayload (h, payload) = do
+ node <- safeDeserializeNode payload
+ let actual = nodeHash node
+ unless (actual == h) $
+ Left $ "node hash mismatch for " ++ unpack h ++ "; payload hashes to " ++ unpack actual
+ Right (h, node)
+
+verifyChildrenPresent :: Map MerkleHash ByteString -> (MerkleHash, Node) -> Either String ()
+verifyChildrenPresent nodeMap (h, node) =
+ case node of
+ NLeaf -> Right ()
+ NStem child -> requireChild h child
+ NFork left right -> requireChild h left >> requireChild h right
+ where
+ requireChild parent child =
+ unless (Map.member child nodeMap) $
+ Left $ "missing child node referenced by " ++ unpack parent ++ ": " ++ unpack child
+
+verifyCompleteClosure :: Map MerkleHash ByteString -> [MerkleHash] -> Either String ()
+verifyCompleteClosure nodeMap roots = do
+ _ <- foldM visit Set.empty roots
+ Right ()
+ where
+ visit seen h
+ | Set.member h seen = Right seen
+ | otherwise = do
+ payload <- case Map.lookup h nodeMap of
+ Nothing -> Left $ "closure missing node: " ++ unpack h
+ Just p -> Right p
+ node <- safeDeserializeNode payload
+ let seen' = Set.insert h seen
+ case node of
+ NLeaf -> Right seen'
+ NStem child -> visit seen' child
+ NFork left right -> visit seen' left >>= \seenL -> visit seenL right
+
+safeDeserializeNode :: ByteString -> Either String Node
+safeDeserializeNode payload =
+ case BS.uncons payload of
+ Just (0x00, rest)
+ | BS.null rest -> Right NLeaf
+ | otherwise -> Left "invalid leaf payload length"
+ Just (0x01, rest)
+ | BS.length rest == 32 -> Right $ NStem (rawToMerkleHash rest)
+ | otherwise -> Left "invalid stem payload length"
+ Just (0x02, rest)
+ | BS.length rest == 64 ->
+ let (left, right) = BS.splitAt 32 rest
+ in Right $ NFork (rawToMerkleHash left) (rawToMerkleHash right)
+ | otherwise -> Left "invalid fork payload length"
+ _ -> Left "invalid merkle node payload"
+
+-- ---------------------------------------------------------------------------
+-- Reachability traversal
+-- ---------------------------------------------------------------------------
+
+collectReachableNodes :: Connection -> MerkleHash -> IO [(MerkleHash, ByteString)]
+collectReachableNodes conn root = do
+ let go seen current = do
+ case Map.lookup current seen of
+ Just _ -> return seen
+ Nothing -> do
+ maybeNode <- getNodeMerkle conn current
+ case maybeNode of
+ Nothing -> error $ "exportBundle: missing Merkle node: " ++ unpack current
+ Just node -> do
+ let payload = serializeNode node
+ seen' = Map.insert current payload seen
+ case node of
+ NLeaf -> return seen'
+ NStem childHash -> go seen' childHash
+ NFork lHash rHash -> go seen' lHash >>= \seenL -> go seenL rHash
+ seen <- go Map.empty root
+ return $ Map.toAscList seen
+
+-- ---------------------------------------------------------------------------
+-- High-level export / import
+-- ---------------------------------------------------------------------------
+
+exportBundle :: Connection -> [MerkleHash] -> IO ByteString
+exportBundle conn hashes = exportNamedBundle conn (zip (defaultExportNames $ length hashes) hashes)
+
+exportNamedBundle :: Connection -> [(Text, MerkleHash)] -> IO ByteString
+exportNamedBundle conn namedHashes = do
+ let hashes = map snd namedHashes
+ entries <- concat <$> mapM (collectReachableNodes conn) hashes
+ let nodeMap = Map.fromList entries
+ manifest = defaultManifest namedHashes (Map.size nodeMap)
+ manifestBytes = BL.toStrict (encode manifest)
+ bundle = Bundle
+ { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion
+ , bundleRoots = hashes
+ , bundleNodes = nodeMap
+ , bundleManifest = manifest
+ , bundleManifestBytes = manifestBytes
+ }
+ return $ encodeBundle bundle
+
+importBundle :: Connection -> ByteString -> IO [MerkleHash]
+importBundle conn bs = case decodeBundle bs of
+ Left err -> error $ "Wire.importBundle: " ++ err
+ Right bundle -> case verifyBundle bundle of
+ Left err -> error $ "Wire.importBundle verify: " ++ err
+ Right () -> do
+ traverse_ (\payload -> do
+ node <- deserializeForImport payload
+ putMerkleNode conn node
+ )
+ (Map.elems $ bundleNodes bundle)
+ registerBundleExports conn bundle
+ return $ bundleRoots bundle
+
+registerBundleExports :: Connection -> Bundle -> IO ()
+registerBundleExports conn bundle =
+ traverse_ registerExport (manifestExports $ bundleManifest bundle)
+ where
+ registerExport exported = do
+ maybeTree <- loadTree conn (exportRoot exported)
+ case maybeTree of
+ Nothing -> error $ "Wire.importBundle: export root missing after node import: " ++ unpack (exportRoot exported)
+ Just tree -> do
+ _ <- storeTerm conn [unpack $ exportName exported] tree
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Primitive binary helpers
+-- ---------------------------------------------------------------------------
+
+encode16 :: Word16 -> ByteString
+encode16 w = BS.pack
+ [ fromIntegral (shiftR w 8)
+ , fromIntegral w
+ ]
+
+encode32 :: Word32 -> ByteString
+encode32 w = BS.pack
+ [ fromIntegral (shiftR w 24)
+ , fromIntegral (shiftR w 16)
+ , fromIntegral (shiftR w 8)
+ , fromIntegral w
+ ]
+
+encode64 :: Word64 -> ByteString
+encode64 w = BS.pack
+ [ fromIntegral (shiftR w 56)
+ , fromIntegral (shiftR w 48)
+ , fromIntegral (shiftR w 40)
+ , fromIntegral (shiftR w 32)
+ , fromIntegral (shiftR w 24)
+ , fromIntegral (shiftR w 16)
+ , fromIntegral (shiftR w 8)
+ , fromIntegral w
+ ]
+
+decode16be :: String -> ByteString -> Either String (Word16, ByteString)
+decode16be label bs
+ | BS.length bs < 2 = Left (label ++ ": not enough bytes for u16")
+ | otherwise =
+ let b0 = fromIntegral (BS.index bs 0) :: Word16
+ b1 = fromIntegral (BS.index bs 1) :: Word16
+ in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs)
+
+-- | Decode a big-endian u32 from the head of a ByteString.
+decode32be :: String -> ByteString -> Either String (Word32, ByteString)
+decode32be label bs
+ | BS.length bs < 4 = Left (label ++ ": not enough bytes for u32")
+ | otherwise =
+ let b0 = fromIntegral (BS.index bs 0) :: Word32
+ b1 = fromIntegral (BS.index bs 1) :: Word32
+ b2 = fromIntegral (BS.index bs 2) :: Word32
+ b3 = fromIntegral (BS.index bs 3) :: Word32
+ val = (b0 `shiftL` 24) .|. (b1 `shiftL` 16)
+ .|. (b2 `shiftL` 8) .|. b3
+ in Right (val, BS.drop 4 bs)
+
+decode64be :: String -> ByteString -> Either String (Word64, ByteString)
+decode64be label bs
+ | BS.length bs < 8 = Left (label ++ ": not enough bytes for u64")
+ | otherwise =
+ let byte i = fromIntegral (BS.index bs i) :: Word64
+ val = (byte 0 `shiftL` 56) .|. (byte 1 `shiftL` 48)
+ .|. (byte 2 `shiftL` 40) .|. (byte 3 `shiftL` 32)
+ .|. (byte 4 `shiftL` 24) .|. (byte 5 `shiftL` 16)
+ .|. (byte 6 `shiftL` 8) .|. byte 7
+ in Right (val, BS.drop 8 bs)
+
+-- ---------------------------------------------------------------------------
+-- Hash conversion
+-- ---------------------------------------------------------------------------
+
+-- | Convert a hex MerkleHash to its raw 32-byte representation.
+merkleHashToRaw :: MerkleHash -> ByteString
+merkleHashToRaw h =
+ case Base16.decode (encodeUtf8 h) of
+ Left _ -> error $ "Wire.merkleHashToRaw: invalid hex: " ++ show h
+ Right bs
+ | BS.length bs == 32 -> bs
+ | otherwise -> error $ "Wire.merkleHashToRaw: expected 32 bytes: " ++ show h
+
+-- | Convert raw 32 bytes back to a hex MerkleHash.
+rawToMerkleHash :: ByteString -> MerkleHash
+rawToMerkleHash bs = decodeUtf8 (Base16.encode bs)
+
+sha256 :: ByteString -> ByteString
+sha256 bytes = convert ((hash bytes) :: Digest SHA256)
+
+defaultExportNames :: Int -> [Text]
+defaultExportNames n =
+ case n of
+ 0 -> []
+ 1 -> ["root"]
+ _ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]
+
+deserializeForImport :: ByteString -> IO Node
+deserializeForImport payload = do
+ result <- try (evaluate $ deserializeNode payload) :: IO (Either SomeException Node)
+ case result of
+ Left err -> error $ "Wire.importBundle: invalid merkle node payload: " ++ show err
+ Right node -> return node
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -6,16 +6,24 @@ import Lexer
import Parser
import REPL
import Research
+import Wire
+import ContentStore
import Control.Exception (evaluate, try, SomeException)
import Control.Monad.IO.Class (liftIO)
+import Data.Bits (xor)
import Data.List (isInfixOf)
+import Data.Text (Text, unpack)
+import Data.Word (Word8)
import Test.Tasty
import Test.Tasty.HUnit
import Text.Megaparsec (runParser)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Database.SQLite.Simple (close, Connection)
main :: IO ()
main = defaultMain tests
@@ -36,6 +44,7 @@ tests = testGroup "Tricu Tests"
, decoding
, elimLambdaSingle
, stressElimLambda
+ , wireTests
]
lexer :: TestTree
@@ -640,3 +649,277 @@ stressElimLambda = testCase "stress elimLambda on wide list under deep curried l
let before = result (evalTricu Map.empty prog)
after = result (evalTricu Map.empty out)
after @?= before
+
+-- --------------------------------------------------------------------------
+-- Wire module tests
+-- --------------------------------------------------------------------------
+
+-- | Helper: create a temporary file-backed DB, store a term, return the
+-- connection and the term (so callers can compare after round-trip).
+storeTermInTempDB :: String -> IO (Connection, Text, T)
+storeTermInTempDB src = do
+ conn <- newContentStore
+ let asts = parseTricu src
+ finalEnv = evalTricu Map.empty asts
+ term = result finalEnv
+ -- storeMerkleNodes returns MerkleHash as Text; storeTerm expects [String]
+ _ <- storeTerm conn [] term
+ return (conn, hashTerm term, term)
+
+-- | Load a term from a DB by its stored hash Text.
+loadTermByHash :: Connection -> Text -> IO T
+loadTermByHash conn h = do
+ maybeTerm <- loadTree conn h
+ case maybeTerm of
+ Just t -> return t
+ Nothing -> errorWithoutStackTrace $ "hash not found in store: " ++ Data.Text.unpack h
+
+-- | Flip one byte in a ByteString at the given index.
+corruptByte :: ByteString -> Int -> ByteString
+corruptByte bs i = BS.take i bs <> BS.pack [(BS.index bs i `xor` 0x01)] <> BS.drop (i + 1) bs
+
+wireTests :: TestTree
+wireTests = testGroup "Wire Tests"
+ [ testCase "Portable bundle: header and manifest declare Tree Calculus object format" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "id = a : a"
+ , "main = id t"
+ ]
+ wireData <- exportBundle srcConn [termHash]
+ BS.take 8 wireData @?= BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00]
+ case decodeBundle wireData of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> do
+ let manifest = bundleManifest bundle
+ tree = manifestTree manifest
+ hashSpec = treeNodeHash tree
+ runtime = manifestRuntime manifest
+ manifestSchema manifest @?= "arborix.bundle.manifest.v1"
+ manifestBundleType manifest @?= "tree-calculus-executable-object"
+ manifestClosure manifest @?= ClosureComplete
+ treeCalculus tree @?= "tree-calculus.v1"
+ treeNodePayload tree @?= "arborix.merkle.payload.v1"
+ nodeHashAlgorithm hashSpec @?= "sha256"
+ nodeHashDomain hashSpec @?= "arborix.merkle.node.v1"
+ runtimeSemantics runtime @?= "tree-calculus.v1"
+ runtimeAbi runtime @?= "arborix.abi.tree.v1"
+ runtimeCapabilities runtime @?= []
+ bundleRoots bundle @?= [termHash]
+ map exportRoot (manifestExports manifest) @?= [termHash]
+ close srcConn
+
+ , testCase "Portable bundle: named exports are manifest aliases for Merkle roots" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "validateEmail = a : a"
+ , "main = validateEmail t"
+ ]
+ wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
+ case decodeBundle wireData of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> do
+ bundleRoots bundle @?= [termHash]
+ case manifestExports (bundleManifest bundle) of
+ [exported] -> do
+ exportName exported @?= "validateEmail"
+ exportRoot exported @?= termHash
+ exportKind exported @?= "term"
+ exportAbi exported @?= "arborix.abi.tree.v1"
+ exports -> assertFailure $ "Expected one export, got: " ++ show exports
+ close srcConn
+
+ , testCase "Portable bundle: renaming an export changes bundle bytes but not tree identity" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "f = a : a"
+ , "main = f t"
+ ]
+ mainBundleData <- exportNamedBundle srcConn [("main", termHash)]
+ renamedBundleData <- exportNamedBundle srcConn [("validate", termHash)]
+ assertBool "Renaming an export should change the manifest/bundle bytes"
+ (mainBundleData /= renamedBundleData)
+ case (decodeBundle mainBundleData, decodeBundle renamedBundleData) of
+ (Right mainBundle, Right renamedBundle) -> do
+ bundleRoots mainBundle @?= [termHash]
+ bundleRoots renamedBundle @?= [termHash]
+ map exportRoot (manifestExports $ bundleManifest mainBundle)
+ @?= map exportRoot (manifestExports $ bundleManifest renamedBundle)
+ map exportName (manifestExports $ bundleManifest mainBundle) @?= ["main"]
+ map exportName (manifestExports $ bundleManifest renamedBundle) @?= ["validate"]
+ (Left err, _) -> assertFailure $ "decodeBundle main failed: " ++ err
+ (_, Left err) -> assertFailure $ "decodeBundle renamed failed: " ++ err
+ close srcConn
+
+ , testCase "Portable bundle: exact byte export is deterministic" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "x = t t"
+ , "main = t x"
+ ]
+ first <- exportBundle srcConn [termHash]
+ second <- exportBundle srcConn [termHash]
+ first @?= second
+ close srcConn
+
+ , testCase "Portable bundle: raw section tampering is rejected by digest verification" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "x = t"
+ , "main = t x"
+ ]
+ wireData <- exportBundle srcConn [termHash]
+ let tampered = corruptByte wireData (BS.length wireData - 1)
+ case decodeBundle tampered of
+ Left err -> assertBool ("Expected section digest mismatch, got: " ++ err)
+ ("digest mismatch" `isInfixOf` err)
+ Right _ -> assertFailure "Expected decodeBundle to reject tampered section bytes"
+ close srcConn
+
+ , testCase "Portable bundle: unsupported manifest semantics are rejected" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "x = t"
+ , "main = t x"
+ ]
+ wireData <- exportBundle srcConn [termHash]
+ case decodeBundle wireData of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> do
+ let manifest = bundleManifest bundle
+ partialBundle = bundle
+ { bundleManifest = manifest { manifestClosure = ClosurePartial }
+ , bundleManifestBytes = BS.empty
+ }
+ capabilityBundle = bundle
+ { bundleManifest = manifest
+ { manifestRuntime = (manifestRuntime manifest)
+ { runtimeCapabilities = ["host.io"]
+ }
+ }
+ , bundleManifestBytes = BS.empty
+ }
+ wrongHashBundle = bundle
+ { bundleManifest = manifest
+ { manifestTree = (manifestTree manifest)
+ { treeNodeHash = (treeNodeHash $ manifestTree manifest)
+ { nodeHashAlgorithm = "blake3" }
+ }
+ }
+ , bundleManifestBytes = BS.empty
+ }
+ case verifyBundle partialBundle of
+ Left err -> assertBool ("Expected closure error, got: " ++ err) ("closure = complete" `isInfixOf` err)
+ Right () -> assertFailure "Expected partial closure to be rejected"
+ case verifyBundle capabilityBundle of
+ Left err -> assertBool ("Expected capability error, got: " ++ err) ("capabilities" `isInfixOf` err)
+ Right () -> assertFailure "Expected runtime capabilities to be rejected"
+ case verifyBundle wrongHashBundle of
+ Left err -> assertBool ("Expected hash algorithm error, got: " ++ err) ("node hash algorithm" `isInfixOf` err)
+ Right () -> assertFailure "Expected unsupported node hash algorithm to be rejected"
+ close srcConn
+
+ , testCase "Portable bundle: import registers manifest export names in fresh content store" $ do
+ (srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
+ [ "validateEmail = a : a"
+ , "main = validateEmail t"
+ ]
+ wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
+ dstConn <- newContentStore
+ _ <- importBundle dstConn wireData
+ loadedByHash <- loadTermByHash dstConn termHash
+ loadedByName <- loadTerm dstConn "validateEmail"
+ loadedByHash @?= originalTerm
+ loadedByName @?= Just originalTerm
+ close srcConn
+ close dstConn
+
+ , testCase "Round-trip: store, export, import, load" $ do
+ -- Store a term
+ (srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
+ [ "x = t"
+ , "y = t x"
+ , "z = t y"
+ , "main = z"
+ ]
+ -- Export by root hash
+ wireData <- exportBundle srcConn [termHash]
+ -- Import into a fresh DB
+ dstConn <- newContentStore
+ _ <- importBundle dstConn wireData
+ -- Load the term back and compare
+ loadedTerm <- loadTermByHash dstConn termHash
+ loadedTerm @?= originalTerm
+ -- Cleanup
+ close srcConn
+ close dstConn
+
+ , testCase "Round-trip: evaluate from original, export, import, load root" $ do
+ (srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
+ [ "add = a b : t (t a) b"
+ , "val = add (t t) (t)"
+ , "main = val"
+ ]
+ -- Export
+ wireData <- exportBundle srcConn [termHash]
+ -- Import into fresh DB
+ dstConn <- newContentStore
+ _ <- importBundle dstConn wireData
+ -- Load the root term by hash and compare
+ loadedTerm <- loadTermByHash dstConn termHash
+ loadedTerm @?= originalTerm
+ close srcConn
+ close dstConn
+
+ , testCase "Negative: corrupt payload byte causes import to fail" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "x = t"
+ , "y = t x"
+ , "z = t y"
+ , "main = z"
+ ]
+ wireData <- exportBundle srcConn [termHash]
+ -- Decode, mutate one node's payload byte, re-encode
+ case decodeBundle wireData of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> do
+ let (h, payload) =
+ head
+ [ (h', p)
+ | (h', p) <- Map.toList (bundleNodes bundle)
+ , BS.length p > 0
+ ]
+ payload' = BS.pack [(BS.head payload `xor` 0x01)] <> BS.tail payload
+ bundle' = bundle { bundleNodes = Map.insert h payload' (bundleNodes bundle) }
+ wireData' = encodeBundle bundle'
+ dstConn <- newContentStore
+ result <- try (importBundle dstConn wireData') :: IO (Either SomeException [MerkleHash])
+ case result of
+ Left e ->
+ assertBool ("Expected hash mismatch or invalid payload, got: " ++ show e)
+ $ "mismatch" `isInfixOf` show e || "invalid" `isInfixOf` show e
+ Right _ ->
+ assertFailure "Expected import to fail on corrupted payload"
+ close dstConn
+ close srcConn
+
+ , testCase "Negative: missing child node causes import to fail" $ do
+ (srcConn, termHash, _) <- storeTermInTempDB $ unlines
+ [ "x = t"
+ , "y = t x"
+ , "z = t y"
+ , "main = z"
+ ]
+ wireData <- exportBundle srcConn [termHash]
+ -- Decode, remove a node, re-encode
+ case decodeBundle wireData of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> do
+ let nodeList = Map.toList (bundleNodes bundle)
+ trimmed = Map.fromList (tail nodeList)
+ newBundle = bundle { bundleNodes = trimmed }
+ newWire = encodeBundle newBundle
+ dstConn <- newContentStore
+ result <- try (importBundle dstConn newWire) :: IO (Either SomeException [MerkleHash])
+ case result of
+ Left e ->
+ assertBool ("Expected verify error, got: " ++ show e) True
+ Right _ ->
+ assertFailure "Expected import to fail on missing child node"
+ close dstConn
+ close srcConn
+ ]
diff --git a/test/fixtures/equalQ.tri.bundle b/test/fixtures/equalQ.tri.bundle
Binary files differ.
diff --git a/test/fixtures/false.tri.bundle b/test/fixtures/false.tri.bundle
Binary files differ.
diff --git a/test/fixtures/id.tri.bundle b/test/fixtures/id.tri.bundle
Binary files differ.
diff --git a/test/fixtures/notQ.tri b/test/fixtures/notQ.tri
@@ -0,0 +1,2 @@
+\!import "base.tri" _
+main = not?
diff --git a/test/fixtures/notQ.tri.bundle b/test/fixtures/notQ.tri.bundle
Binary files differ.
diff --git a/test/fixtures/true.tri.bundle b/test/fixtures/true.tri.bundle
Binary files differ.
diff --git a/tricu.cabal b/tricu.cabal
@@ -51,15 +51,20 @@ executable tricu
, filepath
, fsnotify
, haskeline
+ , http-types
, megaparsec
, memory
, mtl
+ , servant
, sqlite-simple
+ , stm
, tasty
, tasty-hunit
, text
, time
, transformers
+ , wai
+ , warp
, zlib
other-modules:
ContentStore
@@ -70,6 +75,8 @@ executable tricu
Paths_tricu
REPL
Research
+ Server
+ Wire
default-language: Haskell2010
test-suite tricu-tests
@@ -98,15 +105,20 @@ test-suite tricu-tests
, filepath
, fsnotify
, haskeline
+ , http-types
, megaparsec
, memory
, mtl
+ , servant
, sqlite-simple
+ , stm
, tasty
, tasty-hunit
, text
, time
, transformers
+ , warp
+ , wai
, zlib
default-language: Haskell2010
other-modules:
@@ -118,3 +130,5 @@ test-suite tricu-tests
Paths_tricu
REPL
Research
+ Server
+ Wire
